]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
This patch add support for cpu marvell-whitney.
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
6e681866 1/* Ada language support routines for GDB, the GNU debugger.
10a2c479 2
ecd75fc8 3 Copyright (C) 1992-2014 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. */
277 domain_enum namespace;
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'
599 || (strncmp (field_name + len, "___", 3) == 0
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
JB
1005 mapping->encoded != NULL
1006 && strncmp (mapping->decoded, p,
1007 strlen (mapping->decoded)) != 0; mapping += 1)
4c4b4cd2
PH
1008 ;
1009 if (mapping->encoded == NULL)
323e0a4a 1010 error (_("invalid Ada operator name: %s"), p);
4c4b4cd2
PH
1011 strcpy (encoding_buffer + k, mapping->encoded);
1012 k += strlen (mapping->encoded);
1013 break;
1014 }
d2e4a39e 1015 else
4c4b4cd2
PH
1016 {
1017 encoding_buffer[k] = *p;
1018 k += 1;
1019 }
14f9c5c9
AS
1020 }
1021
4c4b4cd2
PH
1022 encoding_buffer[k] = '\0';
1023 return encoding_buffer;
14f9c5c9
AS
1024}
1025
1026/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
1027 quotes, unfolded, but with the quotes stripped away. Result good
1028 to next call. */
1029
d2e4a39e
AS
1030char *
1031ada_fold_name (const char *name)
14f9c5c9 1032{
d2e4a39e 1033 static char *fold_buffer = NULL;
14f9c5c9
AS
1034 static size_t fold_buffer_size = 0;
1035
1036 int len = strlen (name);
d2e4a39e 1037 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
1038
1039 if (name[0] == '\'')
1040 {
d2e4a39e
AS
1041 strncpy (fold_buffer, name + 1, len - 2);
1042 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
1043 }
1044 else
1045 {
1046 int i;
5b4ee69b 1047
14f9c5c9 1048 for (i = 0; i <= len; i += 1)
4c4b4cd2 1049 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
1050 }
1051
1052 return fold_buffer;
1053}
1054
529cad9c
PH
1055/* Return nonzero if C is either a digit or a lowercase alphabet character. */
1056
1057static int
1058is_lower_alphanum (const char c)
1059{
1060 return (isdigit (c) || (isalpha (c) && islower (c)));
1061}
1062
c90092fe
JB
1063/* ENCODED is the linkage name of a symbol and LEN contains its length.
1064 This function saves in LEN the length of that same symbol name but
1065 without either of these suffixes:
29480c32
JB
1066 . .{DIGIT}+
1067 . ${DIGIT}+
1068 . ___{DIGIT}+
1069 . __{DIGIT}+.
c90092fe 1070
29480c32
JB
1071 These are suffixes introduced by the compiler for entities such as
1072 nested subprogram for instance, in order to avoid name clashes.
1073 They do not serve any purpose for the debugger. */
1074
1075static void
1076ada_remove_trailing_digits (const char *encoded, int *len)
1077{
1078 if (*len > 1 && isdigit (encoded[*len - 1]))
1079 {
1080 int i = *len - 2;
5b4ee69b 1081
29480c32
JB
1082 while (i > 0 && isdigit (encoded[i]))
1083 i--;
1084 if (i >= 0 && encoded[i] == '.')
1085 *len = i;
1086 else if (i >= 0 && encoded[i] == '$')
1087 *len = i;
1088 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
1089 *len = i - 2;
1090 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
1091 *len = i - 1;
1092 }
1093}
1094
1095/* Remove the suffix introduced by the compiler for protected object
1096 subprograms. */
1097
1098static void
1099ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1100{
1101 /* Remove trailing N. */
1102
1103 /* Protected entry subprograms are broken into two
1104 separate subprograms: The first one is unprotected, and has
1105 a 'N' suffix; the second is the protected version, and has
0963b4bd 1106 the 'P' suffix. The second calls the first one after handling
29480c32
JB
1107 the protection. Since the P subprograms are internally generated,
1108 we leave these names undecoded, giving the user a clue that this
1109 entity is internal. */
1110
1111 if (*len > 1
1112 && encoded[*len - 1] == 'N'
1113 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1114 *len = *len - 1;
1115}
1116
69fadcdf
JB
1117/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1118
1119static void
1120ada_remove_Xbn_suffix (const char *encoded, int *len)
1121{
1122 int i = *len - 1;
1123
1124 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1125 i--;
1126
1127 if (encoded[i] != 'X')
1128 return;
1129
1130 if (i == 0)
1131 return;
1132
1133 if (isalnum (encoded[i-1]))
1134 *len = i;
1135}
1136
29480c32
JB
1137/* If ENCODED follows the GNAT entity encoding conventions, then return
1138 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1139 replaced by ENCODED.
14f9c5c9 1140
4c4b4cd2 1141 The resulting string is valid until the next call of ada_decode.
29480c32 1142 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1143 is returned. */
1144
1145const char *
1146ada_decode (const char *encoded)
14f9c5c9
AS
1147{
1148 int i, j;
1149 int len0;
d2e4a39e 1150 const char *p;
4c4b4cd2 1151 char *decoded;
14f9c5c9 1152 int at_start_name;
4c4b4cd2
PH
1153 static char *decoding_buffer = NULL;
1154 static size_t decoding_buffer_size = 0;
d2e4a39e 1155
29480c32
JB
1156 /* The name of the Ada main procedure starts with "_ada_".
1157 This prefix is not part of the decoded name, so skip this part
1158 if we see this prefix. */
4c4b4cd2
PH
1159 if (strncmp (encoded, "_ada_", 5) == 0)
1160 encoded += 5;
14f9c5c9 1161
29480c32
JB
1162 /* If the name starts with '_', then it is not a properly encoded
1163 name, so do not attempt to decode it. Similarly, if the name
1164 starts with '<', the name should not be decoded. */
4c4b4cd2 1165 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1166 goto Suppress;
1167
4c4b4cd2 1168 len0 = strlen (encoded);
4c4b4cd2 1169
29480c32
JB
1170 ada_remove_trailing_digits (encoded, &len0);
1171 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1172
4c4b4cd2
PH
1173 /* Remove the ___X.* suffix if present. Do not forget to verify that
1174 the suffix is located before the current "end" of ENCODED. We want
1175 to avoid re-matching parts of ENCODED that have previously been
1176 marked as discarded (by decrementing LEN0). */
1177 p = strstr (encoded, "___");
1178 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1179 {
1180 if (p[3] == 'X')
4c4b4cd2 1181 len0 = p - encoded;
14f9c5c9 1182 else
4c4b4cd2 1183 goto Suppress;
14f9c5c9 1184 }
4c4b4cd2 1185
29480c32
JB
1186 /* Remove any trailing TKB suffix. It tells us that this symbol
1187 is for the body of a task, but that information does not actually
1188 appear in the decoded name. */
1189
4c4b4cd2 1190 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
14f9c5c9 1191 len0 -= 3;
76a01679 1192
a10967fa
JB
1193 /* Remove any trailing TB suffix. The TB suffix is slightly different
1194 from the TKB suffix because it is used for non-anonymous task
1195 bodies. */
1196
1197 if (len0 > 2 && strncmp (encoded + len0 - 2, "TB", 2) == 0)
1198 len0 -= 2;
1199
29480c32
JB
1200 /* Remove trailing "B" suffixes. */
1201 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1202
4c4b4cd2 1203 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
14f9c5c9
AS
1204 len0 -= 1;
1205
4c4b4cd2 1206 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1207
4c4b4cd2
PH
1208 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1209 decoded = decoding_buffer;
14f9c5c9 1210
29480c32
JB
1211 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1212
4c4b4cd2 1213 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1214 {
4c4b4cd2
PH
1215 i = len0 - 2;
1216 while ((i >= 0 && isdigit (encoded[i]))
1217 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1218 i -= 1;
1219 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1220 len0 = i - 1;
1221 else if (encoded[i] == '$')
1222 len0 = i;
d2e4a39e 1223 }
14f9c5c9 1224
29480c32
JB
1225 /* The first few characters that are not alphabetic are not part
1226 of any encoding we use, so we can copy them over verbatim. */
1227
4c4b4cd2
PH
1228 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1229 decoded[j] = encoded[i];
14f9c5c9
AS
1230
1231 at_start_name = 1;
1232 while (i < len0)
1233 {
29480c32 1234 /* Is this a symbol function? */
4c4b4cd2
PH
1235 if (at_start_name && encoded[i] == 'O')
1236 {
1237 int k;
5b4ee69b 1238
4c4b4cd2
PH
1239 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1240 {
1241 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1242 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1243 op_len - 1) == 0)
1244 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1245 {
1246 strcpy (decoded + j, ada_opname_table[k].decoded);
1247 at_start_name = 0;
1248 i += op_len;
1249 j += strlen (ada_opname_table[k].decoded);
1250 break;
1251 }
1252 }
1253 if (ada_opname_table[k].encoded != NULL)
1254 continue;
1255 }
14f9c5c9
AS
1256 at_start_name = 0;
1257
529cad9c
PH
1258 /* Replace "TK__" with "__", which will eventually be translated
1259 into "." (just below). */
1260
4c4b4cd2
PH
1261 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
1262 i += 2;
529cad9c 1263
29480c32
JB
1264 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1265 be translated into "." (just below). These are internal names
1266 generated for anonymous blocks inside which our symbol is nested. */
1267
1268 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1269 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1270 && isdigit (encoded [i+4]))
1271 {
1272 int k = i + 5;
1273
1274 while (k < len0 && isdigit (encoded[k]))
1275 k++; /* Skip any extra digit. */
1276
1277 /* Double-check that the "__B_{DIGITS}+" sequence we found
1278 is indeed followed by "__". */
1279 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1280 i = k;
1281 }
1282
529cad9c
PH
1283 /* Remove _E{DIGITS}+[sb] */
1284
1285 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1286 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1287 one implements the actual entry code, and has a suffix following
1288 the convention above; the second one implements the barrier and
1289 uses the same convention as above, except that the 'E' is replaced
1290 by a 'B'.
1291
1292 Just as above, we do not decode the name of barrier functions
1293 to give the user a clue that the code he is debugging has been
1294 internally generated. */
1295
1296 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1297 && isdigit (encoded[i+2]))
1298 {
1299 int k = i + 3;
1300
1301 while (k < len0 && isdigit (encoded[k]))
1302 k++;
1303
1304 if (k < len0
1305 && (encoded[k] == 'b' || encoded[k] == 's'))
1306 {
1307 k++;
1308 /* Just as an extra precaution, make sure that if this
1309 suffix is followed by anything else, it is a '_'.
1310 Otherwise, we matched this sequence by accident. */
1311 if (k == len0
1312 || (k < len0 && encoded[k] == '_'))
1313 i = k;
1314 }
1315 }
1316
1317 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1318 the GNAT front-end in protected object subprograms. */
1319
1320 if (i < len0 + 3
1321 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1322 {
1323 /* Backtrack a bit up until we reach either the begining of
1324 the encoded name, or "__". Make sure that we only find
1325 digits or lowercase characters. */
1326 const char *ptr = encoded + i - 1;
1327
1328 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1329 ptr--;
1330 if (ptr < encoded
1331 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1332 i++;
1333 }
1334
4c4b4cd2
PH
1335 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1336 {
29480c32
JB
1337 /* This is a X[bn]* sequence not separated from the previous
1338 part of the name with a non-alpha-numeric character (in other
1339 words, immediately following an alpha-numeric character), then
1340 verify that it is placed at the end of the encoded name. If
1341 not, then the encoding is not valid and we should abort the
1342 decoding. Otherwise, just skip it, it is used in body-nested
1343 package names. */
4c4b4cd2
PH
1344 do
1345 i += 1;
1346 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1347 if (i < len0)
1348 goto Suppress;
1349 }
cdc7bb92 1350 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1351 {
29480c32 1352 /* Replace '__' by '.'. */
4c4b4cd2
PH
1353 decoded[j] = '.';
1354 at_start_name = 1;
1355 i += 2;
1356 j += 1;
1357 }
14f9c5c9 1358 else
4c4b4cd2 1359 {
29480c32
JB
1360 /* It's a character part of the decoded name, so just copy it
1361 over. */
4c4b4cd2
PH
1362 decoded[j] = encoded[i];
1363 i += 1;
1364 j += 1;
1365 }
14f9c5c9 1366 }
4c4b4cd2 1367 decoded[j] = '\000';
14f9c5c9 1368
29480c32
JB
1369 /* Decoded names should never contain any uppercase character.
1370 Double-check this, and abort the decoding if we find one. */
1371
4c4b4cd2
PH
1372 for (i = 0; decoded[i] != '\0'; i += 1)
1373 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1374 goto Suppress;
1375
4c4b4cd2
PH
1376 if (strcmp (decoded, encoded) == 0)
1377 return encoded;
1378 else
1379 return decoded;
14f9c5c9
AS
1380
1381Suppress:
4c4b4cd2
PH
1382 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1383 decoded = decoding_buffer;
1384 if (encoded[0] == '<')
1385 strcpy (decoded, encoded);
14f9c5c9 1386 else
88c15c34 1387 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1388 return decoded;
1389
1390}
1391
1392/* Table for keeping permanent unique copies of decoded names. Once
1393 allocated, names in this table are never released. While this is a
1394 storage leak, it should not be significant unless there are massive
1395 changes in the set of decoded names in successive versions of a
1396 symbol table loaded during a single session. */
1397static struct htab *decoded_names_store;
1398
1399/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1400 in the language-specific part of GSYMBOL, if it has not been
1401 previously computed. Tries to save the decoded name in the same
1402 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1403 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1404 GSYMBOL).
4c4b4cd2
PH
1405 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1406 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1407 when a decoded name is cached in it. */
4c4b4cd2 1408
45e6c716 1409const char *
f85f34ed 1410ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1411{
f85f34ed
TT
1412 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1413 const char **resultp =
1414 &gsymbol->language_specific.mangled_lang.demangled_name;
5b4ee69b 1415
f85f34ed 1416 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1417 {
1418 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1419 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1420
f85f34ed 1421 gsymbol->ada_mangled = 1;
5b4ee69b 1422
f85f34ed
TT
1423 if (obstack != NULL)
1424 *resultp = obstack_copy0 (obstack, decoded, strlen (decoded));
1425 else
76a01679 1426 {
f85f34ed
TT
1427 /* Sometimes, we can't find a corresponding objfile, in
1428 which case, we put the result on the heap. Since we only
1429 decode when needed, we hope this usually does not cause a
1430 significant memory leak (FIXME). */
1431
76a01679
JB
1432 char **slot = (char **) htab_find_slot (decoded_names_store,
1433 decoded, INSERT);
5b4ee69b 1434
76a01679
JB
1435 if (*slot == NULL)
1436 *slot = xstrdup (decoded);
1437 *resultp = *slot;
1438 }
4c4b4cd2 1439 }
14f9c5c9 1440
4c4b4cd2
PH
1441 return *resultp;
1442}
76a01679 1443
2c0b251b 1444static char *
76a01679 1445ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1446{
1447 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1448}
1449
1450/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
4c4b4cd2
PH
1451 suffixes that encode debugging information or leading _ada_ on
1452 SYM_NAME (see is_name_suffix commentary for the debugging
1453 information that is ignored). If WILD, then NAME need only match a
1454 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1455 either argument is NULL. */
14f9c5c9 1456
2c0b251b 1457static int
40658b94 1458match_name (const char *sym_name, const char *name, int wild)
14f9c5c9
AS
1459{
1460 if (sym_name == NULL || name == NULL)
1461 return 0;
1462 else if (wild)
73589123 1463 return wild_match (sym_name, name) == 0;
d2e4a39e
AS
1464 else
1465 {
1466 int len_name = strlen (name);
5b4ee69b 1467
4c4b4cd2
PH
1468 return (strncmp (sym_name, name, len_name) == 0
1469 && is_name_suffix (sym_name + len_name))
1470 || (strncmp (sym_name, "_ada_", 5) == 0
1471 && strncmp (sym_name + 5, name, len_name) == 0
1472 && is_name_suffix (sym_name + len_name + 5));
d2e4a39e 1473 }
14f9c5c9 1474}
14f9c5c9 1475\f
d2e4a39e 1476
4c4b4cd2 1477 /* Arrays */
14f9c5c9 1478
28c85d6c
JB
1479/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1480 generated by the GNAT compiler to describe the index type used
1481 for each dimension of an array, check whether it follows the latest
1482 known encoding. If not, fix it up to conform to the latest encoding.
1483 Otherwise, do nothing. This function also does nothing if
1484 INDEX_DESC_TYPE is NULL.
1485
1486 The GNAT encoding used to describle the array index type evolved a bit.
1487 Initially, the information would be provided through the name of each
1488 field of the structure type only, while the type of these fields was
1489 described as unspecified and irrelevant. The debugger was then expected
1490 to perform a global type lookup using the name of that field in order
1491 to get access to the full index type description. Because these global
1492 lookups can be very expensive, the encoding was later enhanced to make
1493 the global lookup unnecessary by defining the field type as being
1494 the full index type description.
1495
1496 The purpose of this routine is to allow us to support older versions
1497 of the compiler by detecting the use of the older encoding, and by
1498 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1499 we essentially replace each field's meaningless type by the associated
1500 index subtype). */
1501
1502void
1503ada_fixup_array_indexes_type (struct type *index_desc_type)
1504{
1505 int i;
1506
1507 if (index_desc_type == NULL)
1508 return;
1509 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1510
1511 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1512 to check one field only, no need to check them all). If not, return
1513 now.
1514
1515 If our INDEX_DESC_TYPE was generated using the older encoding,
1516 the field type should be a meaningless integer type whose name
1517 is not equal to the field name. */
1518 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1519 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1520 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1521 return;
1522
1523 /* Fixup each field of INDEX_DESC_TYPE. */
1524 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1525 {
0d5cff50 1526 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1527 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1528
1529 if (raw_type)
1530 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1531 }
1532}
1533
4c4b4cd2 1534/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1535
d2e4a39e
AS
1536static char *bound_name[] = {
1537 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1538 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1539};
1540
1541/* Maximum number of array dimensions we are prepared to handle. */
1542
4c4b4cd2 1543#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1544
14f9c5c9 1545
4c4b4cd2
PH
1546/* The desc_* routines return primitive portions of array descriptors
1547 (fat pointers). */
14f9c5c9
AS
1548
1549/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1550 level of indirection, if needed. */
1551
d2e4a39e
AS
1552static struct type *
1553desc_base_type (struct type *type)
14f9c5c9
AS
1554{
1555 if (type == NULL)
1556 return NULL;
61ee279c 1557 type = ada_check_typedef (type);
720d1a40
JB
1558 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1559 type = ada_typedef_target_type (type);
1560
1265e4aa
JB
1561 if (type != NULL
1562 && (TYPE_CODE (type) == TYPE_CODE_PTR
1563 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1564 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1565 else
1566 return type;
1567}
1568
4c4b4cd2
PH
1569/* True iff TYPE indicates a "thin" array pointer type. */
1570
14f9c5c9 1571static int
d2e4a39e 1572is_thin_pntr (struct type *type)
14f9c5c9 1573{
d2e4a39e 1574 return
14f9c5c9
AS
1575 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1576 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1577}
1578
4c4b4cd2
PH
1579/* The descriptor type for thin pointer type TYPE. */
1580
d2e4a39e
AS
1581static struct type *
1582thin_descriptor_type (struct type *type)
14f9c5c9 1583{
d2e4a39e 1584 struct type *base_type = desc_base_type (type);
5b4ee69b 1585
14f9c5c9
AS
1586 if (base_type == NULL)
1587 return NULL;
1588 if (is_suffix (ada_type_name (base_type), "___XVE"))
1589 return base_type;
d2e4a39e 1590 else
14f9c5c9 1591 {
d2e4a39e 1592 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1593
14f9c5c9 1594 if (alt_type == NULL)
4c4b4cd2 1595 return base_type;
14f9c5c9 1596 else
4c4b4cd2 1597 return alt_type;
14f9c5c9
AS
1598 }
1599}
1600
4c4b4cd2
PH
1601/* A pointer to the array data for thin-pointer value VAL. */
1602
d2e4a39e
AS
1603static struct value *
1604thin_data_pntr (struct value *val)
14f9c5c9 1605{
828292f2 1606 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1607 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1608
556bdfd4
UW
1609 data_type = lookup_pointer_type (data_type);
1610
14f9c5c9 1611 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1612 return value_cast (data_type, value_copy (val));
d2e4a39e 1613 else
42ae5230 1614 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1615}
1616
4c4b4cd2
PH
1617/* True iff TYPE indicates a "thick" array pointer type. */
1618
14f9c5c9 1619static int
d2e4a39e 1620is_thick_pntr (struct type *type)
14f9c5c9
AS
1621{
1622 type = desc_base_type (type);
1623 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1624 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1625}
1626
4c4b4cd2
PH
1627/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1628 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1629
d2e4a39e
AS
1630static struct type *
1631desc_bounds_type (struct type *type)
14f9c5c9 1632{
d2e4a39e 1633 struct type *r;
14f9c5c9
AS
1634
1635 type = desc_base_type (type);
1636
1637 if (type == NULL)
1638 return NULL;
1639 else if (is_thin_pntr (type))
1640 {
1641 type = thin_descriptor_type (type);
1642 if (type == NULL)
4c4b4cd2 1643 return NULL;
14f9c5c9
AS
1644 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1645 if (r != NULL)
61ee279c 1646 return ada_check_typedef (r);
14f9c5c9
AS
1647 }
1648 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1649 {
1650 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1651 if (r != NULL)
61ee279c 1652 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1653 }
1654 return NULL;
1655}
1656
1657/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1658 one, a pointer to its bounds data. Otherwise NULL. */
1659
d2e4a39e
AS
1660static struct value *
1661desc_bounds (struct value *arr)
14f9c5c9 1662{
df407dfe 1663 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1664
d2e4a39e 1665 if (is_thin_pntr (type))
14f9c5c9 1666 {
d2e4a39e 1667 struct type *bounds_type =
4c4b4cd2 1668 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1669 LONGEST addr;
1670
4cdfadb1 1671 if (bounds_type == NULL)
323e0a4a 1672 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1673
1674 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1675 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1676 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1677 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1678 addr = value_as_long (arr);
d2e4a39e 1679 else
42ae5230 1680 addr = value_address (arr);
14f9c5c9 1681
d2e4a39e 1682 return
4c4b4cd2
PH
1683 value_from_longest (lookup_pointer_type (bounds_type),
1684 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1685 }
1686
1687 else if (is_thick_pntr (type))
05e522ef
JB
1688 {
1689 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1690 _("Bad GNAT array descriptor"));
1691 struct type *p_bounds_type = value_type (p_bounds);
1692
1693 if (p_bounds_type
1694 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1695 {
1696 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1697
1698 if (TYPE_STUB (target_type))
1699 p_bounds = value_cast (lookup_pointer_type
1700 (ada_check_typedef (target_type)),
1701 p_bounds);
1702 }
1703 else
1704 error (_("Bad GNAT array descriptor"));
1705
1706 return p_bounds;
1707 }
14f9c5c9
AS
1708 else
1709 return NULL;
1710}
1711
4c4b4cd2
PH
1712/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1713 position of the field containing the address of the bounds data. */
1714
14f9c5c9 1715static int
d2e4a39e 1716fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1717{
1718 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1719}
1720
1721/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1722 size of the field containing the address of the bounds data. */
1723
14f9c5c9 1724static int
d2e4a39e 1725fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1726{
1727 type = desc_base_type (type);
1728
d2e4a39e 1729 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1730 return TYPE_FIELD_BITSIZE (type, 1);
1731 else
61ee279c 1732 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1733}
1734
4c4b4cd2 1735/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1736 pointer to one, the type of its array data (a array-with-no-bounds type);
1737 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1738 data. */
4c4b4cd2 1739
d2e4a39e 1740static struct type *
556bdfd4 1741desc_data_target_type (struct type *type)
14f9c5c9
AS
1742{
1743 type = desc_base_type (type);
1744
4c4b4cd2 1745 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1746 if (is_thin_pntr (type))
556bdfd4 1747 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1748 else if (is_thick_pntr (type))
556bdfd4
UW
1749 {
1750 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1751
1752 if (data_type
1753 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1754 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1755 }
1756
1757 return NULL;
14f9c5c9
AS
1758}
1759
1760/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1761 its array data. */
4c4b4cd2 1762
d2e4a39e
AS
1763static struct value *
1764desc_data (struct value *arr)
14f9c5c9 1765{
df407dfe 1766 struct type *type = value_type (arr);
5b4ee69b 1767
14f9c5c9
AS
1768 if (is_thin_pntr (type))
1769 return thin_data_pntr (arr);
1770 else if (is_thick_pntr (type))
d2e4a39e 1771 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1772 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1773 else
1774 return NULL;
1775}
1776
1777
1778/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1779 position of the field containing the address of the data. */
1780
14f9c5c9 1781static int
d2e4a39e 1782fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1783{
1784 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1785}
1786
1787/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1788 size of the field containing the address of the data. */
1789
14f9c5c9 1790static int
d2e4a39e 1791fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1792{
1793 type = desc_base_type (type);
1794
1795 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1796 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1797 else
14f9c5c9
AS
1798 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1799}
1800
4c4b4cd2 1801/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1802 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1803 bound, if WHICH is 1. The first bound is I=1. */
1804
d2e4a39e
AS
1805static struct value *
1806desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1807{
d2e4a39e 1808 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1809 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1810}
1811
1812/* If BOUNDS is an array-bounds structure type, return the bit position
1813 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1814 bound, if WHICH is 1. The first bound is I=1. */
1815
14f9c5c9 1816static int
d2e4a39e 1817desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1818{
d2e4a39e 1819 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1820}
1821
1822/* If BOUNDS is an array-bounds structure type, return the bit field size
1823 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1824 bound, if WHICH is 1. The first bound is I=1. */
1825
76a01679 1826static int
d2e4a39e 1827desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1828{
1829 type = desc_base_type (type);
1830
d2e4a39e
AS
1831 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1832 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1833 else
1834 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1835}
1836
1837/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1838 Ith bound (numbering from 1). Otherwise, NULL. */
1839
d2e4a39e
AS
1840static struct type *
1841desc_index_type (struct type *type, int i)
14f9c5c9
AS
1842{
1843 type = desc_base_type (type);
1844
1845 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1846 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1847 else
14f9c5c9
AS
1848 return NULL;
1849}
1850
4c4b4cd2
PH
1851/* The number of index positions in the array-bounds type TYPE.
1852 Return 0 if TYPE is NULL. */
1853
14f9c5c9 1854static int
d2e4a39e 1855desc_arity (struct type *type)
14f9c5c9
AS
1856{
1857 type = desc_base_type (type);
1858
1859 if (type != NULL)
1860 return TYPE_NFIELDS (type) / 2;
1861 return 0;
1862}
1863
4c4b4cd2
PH
1864/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1865 an array descriptor type (representing an unconstrained array
1866 type). */
1867
76a01679
JB
1868static int
1869ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1870{
1871 if (type == NULL)
1872 return 0;
61ee279c 1873 type = ada_check_typedef (type);
4c4b4cd2 1874 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1875 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1876}
1877
52ce6436 1878/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1879 * to one. */
52ce6436 1880
2c0b251b 1881static int
52ce6436
PH
1882ada_is_array_type (struct type *type)
1883{
1884 while (type != NULL
1885 && (TYPE_CODE (type) == TYPE_CODE_PTR
1886 || TYPE_CODE (type) == TYPE_CODE_REF))
1887 type = TYPE_TARGET_TYPE (type);
1888 return ada_is_direct_array_type (type);
1889}
1890
4c4b4cd2 1891/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1892
14f9c5c9 1893int
4c4b4cd2 1894ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1895{
1896 if (type == NULL)
1897 return 0;
61ee279c 1898 type = ada_check_typedef (type);
14f9c5c9 1899 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1900 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1901 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1902 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1903}
1904
4c4b4cd2
PH
1905/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1906
14f9c5c9 1907int
4c4b4cd2 1908ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1909{
556bdfd4 1910 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1911
1912 if (type == NULL)
1913 return 0;
61ee279c 1914 type = ada_check_typedef (type);
556bdfd4
UW
1915 return (data_type != NULL
1916 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1917 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1918}
1919
1920/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1921 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1922 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1923 is still needed. */
1924
14f9c5c9 1925int
ebf56fd3 1926ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1927{
d2e4a39e 1928 return
14f9c5c9
AS
1929 type != NULL
1930 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1931 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1932 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1933 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1934}
1935
1936
4c4b4cd2 1937/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1938 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1939 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1940 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1941 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1942 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1943 a descriptor. */
d2e4a39e
AS
1944struct type *
1945ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1946{
ad82864c
JB
1947 if (ada_is_constrained_packed_array_type (value_type (arr)))
1948 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1949
df407dfe
AC
1950 if (!ada_is_array_descriptor_type (value_type (arr)))
1951 return value_type (arr);
d2e4a39e
AS
1952
1953 if (!bounds)
ad82864c
JB
1954 {
1955 struct type *array_type =
1956 ada_check_typedef (desc_data_target_type (value_type (arr)));
1957
1958 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1959 TYPE_FIELD_BITSIZE (array_type, 0) =
1960 decode_packed_array_bitsize (value_type (arr));
1961
1962 return array_type;
1963 }
14f9c5c9
AS
1964 else
1965 {
d2e4a39e 1966 struct type *elt_type;
14f9c5c9 1967 int arity;
d2e4a39e 1968 struct value *descriptor;
14f9c5c9 1969
df407dfe
AC
1970 elt_type = ada_array_element_type (value_type (arr), -1);
1971 arity = ada_array_arity (value_type (arr));
14f9c5c9 1972
d2e4a39e 1973 if (elt_type == NULL || arity == 0)
df407dfe 1974 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
1975
1976 descriptor = desc_bounds (arr);
d2e4a39e 1977 if (value_as_long (descriptor) == 0)
4c4b4cd2 1978 return NULL;
d2e4a39e 1979 while (arity > 0)
4c4b4cd2 1980 {
e9bb382b
UW
1981 struct type *range_type = alloc_type_copy (value_type (arr));
1982 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
1983 struct value *low = desc_one_bound (descriptor, arity, 0);
1984 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 1985
5b4ee69b 1986 arity -= 1;
0c9c3474
SA
1987 create_static_range_type (range_type, value_type (low),
1988 longest_to_int (value_as_long (low)),
1989 longest_to_int (value_as_long (high)));
4c4b4cd2 1990 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
1991
1992 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
1993 {
1994 /* We need to store the element packed bitsize, as well as
1995 recompute the array size, because it was previously
1996 computed based on the unpacked element size. */
1997 LONGEST lo = value_as_long (low);
1998 LONGEST hi = value_as_long (high);
1999
2000 TYPE_FIELD_BITSIZE (elt_type, 0) =
2001 decode_packed_array_bitsize (value_type (arr));
2002 /* If the array has no element, then the size is already
2003 zero, and does not need to be recomputed. */
2004 if (lo < hi)
2005 {
2006 int array_bitsize =
2007 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2008
2009 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2010 }
2011 }
4c4b4cd2 2012 }
14f9c5c9
AS
2013
2014 return lookup_pointer_type (elt_type);
2015 }
2016}
2017
2018/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
2019 Otherwise, returns either a standard GDB array with bounds set
2020 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2021 GDB array. Returns NULL if ARR is a null fat pointer. */
2022
d2e4a39e
AS
2023struct value *
2024ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 2025{
df407dfe 2026 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2027 {
d2e4a39e 2028 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 2029
14f9c5c9 2030 if (arrType == NULL)
4c4b4cd2 2031 return NULL;
14f9c5c9
AS
2032 return value_cast (arrType, value_copy (desc_data (arr)));
2033 }
ad82864c
JB
2034 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2035 return decode_constrained_packed_array (arr);
14f9c5c9
AS
2036 else
2037 return arr;
2038}
2039
2040/* If ARR does not represent an array, returns ARR unchanged.
2041 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
2042 be ARR itself if it already is in the proper form). */
2043
720d1a40 2044struct value *
d2e4a39e 2045ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 2046{
df407dfe 2047 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2048 {
d2e4a39e 2049 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 2050
14f9c5c9 2051 if (arrVal == NULL)
323e0a4a 2052 error (_("Bounds unavailable for null array pointer."));
c1b5a1a6 2053 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
2054 return value_ind (arrVal);
2055 }
ad82864c
JB
2056 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2057 return decode_constrained_packed_array (arr);
d2e4a39e 2058 else
14f9c5c9
AS
2059 return arr;
2060}
2061
2062/* If TYPE represents a GNAT array type, return it translated to an
2063 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
2064 packing). For other types, is the identity. */
2065
d2e4a39e
AS
2066struct type *
2067ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 2068{
ad82864c
JB
2069 if (ada_is_constrained_packed_array_type (type))
2070 return decode_constrained_packed_array_type (type);
17280b9f
UW
2071
2072 if (ada_is_array_descriptor_type (type))
556bdfd4 2073 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
2074
2075 return type;
14f9c5c9
AS
2076}
2077
4c4b4cd2
PH
2078/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2079
ad82864c
JB
2080static int
2081ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
2082{
2083 if (type == NULL)
2084 return 0;
4c4b4cd2 2085 type = desc_base_type (type);
61ee279c 2086 type = ada_check_typedef (type);
d2e4a39e 2087 return
14f9c5c9
AS
2088 ada_type_name (type) != NULL
2089 && strstr (ada_type_name (type), "___XP") != NULL;
2090}
2091
ad82864c
JB
2092/* Non-zero iff TYPE represents a standard GNAT constrained
2093 packed-array type. */
2094
2095int
2096ada_is_constrained_packed_array_type (struct type *type)
2097{
2098 return ada_is_packed_array_type (type)
2099 && !ada_is_array_descriptor_type (type);
2100}
2101
2102/* Non-zero iff TYPE represents an array descriptor for a
2103 unconstrained packed-array type. */
2104
2105static int
2106ada_is_unconstrained_packed_array_type (struct type *type)
2107{
2108 return ada_is_packed_array_type (type)
2109 && ada_is_array_descriptor_type (type);
2110}
2111
2112/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2113 return the size of its elements in bits. */
2114
2115static long
2116decode_packed_array_bitsize (struct type *type)
2117{
0d5cff50
DE
2118 const char *raw_name;
2119 const char *tail;
ad82864c
JB
2120 long bits;
2121
720d1a40
JB
2122 /* Access to arrays implemented as fat pointers are encoded as a typedef
2123 of the fat pointer type. We need the name of the fat pointer type
2124 to do the decoding, so strip the typedef layer. */
2125 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2126 type = ada_typedef_target_type (type);
2127
2128 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2129 if (!raw_name)
2130 raw_name = ada_type_name (desc_base_type (type));
2131
2132 if (!raw_name)
2133 return 0;
2134
2135 tail = strstr (raw_name, "___XP");
720d1a40 2136 gdb_assert (tail != NULL);
ad82864c
JB
2137
2138 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2139 {
2140 lim_warning
2141 (_("could not understand bit size information on packed array"));
2142 return 0;
2143 }
2144
2145 return bits;
2146}
2147
14f9c5c9
AS
2148/* Given that TYPE is a standard GDB array type with all bounds filled
2149 in, and that the element size of its ultimate scalar constituents
2150 (that is, either its elements, or, if it is an array of arrays, its
2151 elements' elements, etc.) is *ELT_BITS, return an identical type,
2152 but with the bit sizes of its elements (and those of any
2153 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2 2154 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
4a46959e
JB
2155 in bits.
2156
2157 Note that, for arrays whose index type has an XA encoding where
2158 a bound references a record discriminant, getting that discriminant,
2159 and therefore the actual value of that bound, is not possible
2160 because none of the given parameters gives us access to the record.
2161 This function assumes that it is OK in the context where it is being
2162 used to return an array whose bounds are still dynamic and where
2163 the length is arbitrary. */
4c4b4cd2 2164
d2e4a39e 2165static struct type *
ad82864c 2166constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2167{
d2e4a39e
AS
2168 struct type *new_elt_type;
2169 struct type *new_type;
99b1c762
JB
2170 struct type *index_type_desc;
2171 struct type *index_type;
14f9c5c9
AS
2172 LONGEST low_bound, high_bound;
2173
61ee279c 2174 type = ada_check_typedef (type);
14f9c5c9
AS
2175 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2176 return type;
2177
99b1c762
JB
2178 index_type_desc = ada_find_parallel_type (type, "___XA");
2179 if (index_type_desc)
2180 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2181 NULL);
2182 else
2183 index_type = TYPE_INDEX_TYPE (type);
2184
e9bb382b 2185 new_type = alloc_type_copy (type);
ad82864c
JB
2186 new_elt_type =
2187 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2188 elt_bits);
99b1c762 2189 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2190 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2191 TYPE_NAME (new_type) = ada_type_name (type);
2192
4a46959e
JB
2193 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2194 && is_dynamic_type (check_typedef (index_type)))
2195 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2196 low_bound = high_bound = 0;
2197 if (high_bound < low_bound)
2198 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2199 else
14f9c5c9
AS
2200 {
2201 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2202 TYPE_LENGTH (new_type) =
4c4b4cd2 2203 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2204 }
2205
876cecd0 2206 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2207 return new_type;
2208}
2209
ad82864c
JB
2210/* The array type encoded by TYPE, where
2211 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2212
d2e4a39e 2213static struct type *
ad82864c 2214decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2215{
0d5cff50 2216 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2217 char *name;
0d5cff50 2218 const char *tail;
d2e4a39e 2219 struct type *shadow_type;
14f9c5c9 2220 long bits;
14f9c5c9 2221
727e3d2e
JB
2222 if (!raw_name)
2223 raw_name = ada_type_name (desc_base_type (type));
2224
2225 if (!raw_name)
2226 return NULL;
2227
2228 name = (char *) alloca (strlen (raw_name) + 1);
2229 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2230 type = desc_base_type (type);
2231
14f9c5c9
AS
2232 memcpy (name, raw_name, tail - raw_name);
2233 name[tail - raw_name] = '\000';
2234
b4ba55a1
JB
2235 shadow_type = ada_find_parallel_type_with_name (type, name);
2236
2237 if (shadow_type == NULL)
14f9c5c9 2238 {
323e0a4a 2239 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2240 return NULL;
2241 }
cb249c71 2242 CHECK_TYPEDEF (shadow_type);
14f9c5c9
AS
2243
2244 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2245 {
0963b4bd
MS
2246 lim_warning (_("could not understand bounds "
2247 "information on packed array"));
14f9c5c9
AS
2248 return NULL;
2249 }
d2e4a39e 2250
ad82864c
JB
2251 bits = decode_packed_array_bitsize (type);
2252 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2253}
2254
ad82864c
JB
2255/* Given that ARR is a struct value *indicating a GNAT constrained packed
2256 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2257 standard GDB array type except that the BITSIZEs of the array
2258 target types are set to the number of bits in each element, and the
4c4b4cd2 2259 type length is set appropriately. */
14f9c5c9 2260
d2e4a39e 2261static struct value *
ad82864c 2262decode_constrained_packed_array (struct value *arr)
14f9c5c9 2263{
4c4b4cd2 2264 struct type *type;
14f9c5c9 2265
11aa919a
PMR
2266 /* If our value is a pointer, then dereference it. Likewise if
2267 the value is a reference. Make sure that this operation does not
2268 cause the target type to be fixed, as this would indirectly cause
2269 this array to be decoded. The rest of the routine assumes that
2270 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2271 and "value_ind" routines to perform the dereferencing, as opposed
2272 to using "ada_coerce_ref" or "ada_value_ind". */
2273 arr = coerce_ref (arr);
828292f2 2274 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2275 arr = value_ind (arr);
4c4b4cd2 2276
ad82864c 2277 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2278 if (type == NULL)
2279 {
323e0a4a 2280 error (_("can't unpack array"));
14f9c5c9
AS
2281 return NULL;
2282 }
61ee279c 2283
50810684 2284 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2285 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2286 {
2287 /* This is a (right-justified) modular type representing a packed
2288 array with no wrapper. In order to interpret the value through
2289 the (left-justified) packed array type we just built, we must
2290 first left-justify it. */
2291 int bit_size, bit_pos;
2292 ULONGEST mod;
2293
df407dfe 2294 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2295 bit_size = 0;
2296 while (mod > 0)
2297 {
2298 bit_size += 1;
2299 mod >>= 1;
2300 }
df407dfe 2301 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2302 arr = ada_value_primitive_packed_val (arr, NULL,
2303 bit_pos / HOST_CHAR_BIT,
2304 bit_pos % HOST_CHAR_BIT,
2305 bit_size,
2306 type);
2307 }
2308
4c4b4cd2 2309 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2310}
2311
2312
2313/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2314 given in IND. ARR must be a simple array. */
14f9c5c9 2315
d2e4a39e
AS
2316static struct value *
2317value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2318{
2319 int i;
2320 int bits, elt_off, bit_off;
2321 long elt_total_bit_offset;
d2e4a39e
AS
2322 struct type *elt_type;
2323 struct value *v;
14f9c5c9
AS
2324
2325 bits = 0;
2326 elt_total_bit_offset = 0;
df407dfe 2327 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2328 for (i = 0; i < arity; i += 1)
14f9c5c9 2329 {
d2e4a39e 2330 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2331 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2332 error
0963b4bd
MS
2333 (_("attempt to do packed indexing of "
2334 "something other than a packed array"));
14f9c5c9 2335 else
4c4b4cd2
PH
2336 {
2337 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2338 LONGEST lowerbound, upperbound;
2339 LONGEST idx;
2340
2341 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2342 {
323e0a4a 2343 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2344 lowerbound = upperbound = 0;
2345 }
2346
3cb382c9 2347 idx = pos_atr (ind[i]);
4c4b4cd2 2348 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2349 lim_warning (_("packed array index %ld out of bounds"),
2350 (long) idx);
4c4b4cd2
PH
2351 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2352 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2353 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2354 }
14f9c5c9
AS
2355 }
2356 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2357 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2358
2359 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2360 bits, elt_type);
14f9c5c9
AS
2361 return v;
2362}
2363
4c4b4cd2 2364/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2365
2366static int
d2e4a39e 2367has_negatives (struct type *type)
14f9c5c9 2368{
d2e4a39e
AS
2369 switch (TYPE_CODE (type))
2370 {
2371 default:
2372 return 0;
2373 case TYPE_CODE_INT:
2374 return !TYPE_UNSIGNED (type);
2375 case TYPE_CODE_RANGE:
2376 return TYPE_LOW_BOUND (type) < 0;
2377 }
14f9c5c9 2378}
d2e4a39e 2379
14f9c5c9
AS
2380
2381/* Create a new value of type TYPE from the contents of OBJ starting
2382 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2383 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
0963b4bd 2384 assigning through the result will set the field fetched from.
4c4b4cd2
PH
2385 VALADDR is ignored unless OBJ is NULL, in which case,
2386 VALADDR+OFFSET must address the start of storage containing the
2387 packed value. The value returned in this case is never an lval.
2388 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
14f9c5c9 2389
d2e4a39e 2390struct value *
fc1a4b47 2391ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
a2bd3dcd 2392 long offset, int bit_offset, int bit_size,
4c4b4cd2 2393 struct type *type)
14f9c5c9 2394{
d2e4a39e 2395 struct value *v;
4c4b4cd2
PH
2396 int src, /* Index into the source area */
2397 targ, /* Index into the target area */
2398 srcBitsLeft, /* Number of source bits left to move */
2399 nsrc, ntarg, /* Number of source and target bytes */
2400 unusedLS, /* Number of bits in next significant
2401 byte of source that are unused */
2402 accumSize; /* Number of meaningful bits in accum */
2403 unsigned char *bytes; /* First byte containing data to unpack */
d2e4a39e 2404 unsigned char *unpacked;
4c4b4cd2 2405 unsigned long accum; /* Staging area for bits being transferred */
14f9c5c9
AS
2406 unsigned char sign;
2407 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
4c4b4cd2
PH
2408 /* Transmit bytes from least to most significant; delta is the direction
2409 the indices move. */
50810684 2410 int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1;
14f9c5c9 2411
61ee279c 2412 type = ada_check_typedef (type);
14f9c5c9
AS
2413
2414 if (obj == NULL)
2415 {
2416 v = allocate_value (type);
d2e4a39e 2417 bytes = (unsigned char *) (valaddr + offset);
14f9c5c9 2418 }
9214ee5f 2419 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
14f9c5c9 2420 {
53ba8333 2421 v = value_at (type, value_address (obj));
9f1f738a 2422 type = value_type (v);
d2e4a39e 2423 bytes = (unsigned char *) alloca (len);
53ba8333 2424 read_memory (value_address (v) + offset, bytes, len);
14f9c5c9 2425 }
d2e4a39e 2426 else
14f9c5c9
AS
2427 {
2428 v = allocate_value (type);
0fd88904 2429 bytes = (unsigned char *) value_contents (obj) + offset;
14f9c5c9 2430 }
d2e4a39e
AS
2431
2432 if (obj != NULL)
14f9c5c9 2433 {
53ba8333 2434 long new_offset = offset;
5b4ee69b 2435
74bcbdf3 2436 set_value_component_location (v, obj);
9bbda503
AC
2437 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2438 set_value_bitsize (v, bit_size);
df407dfe 2439 if (value_bitpos (v) >= HOST_CHAR_BIT)
4c4b4cd2 2440 {
53ba8333 2441 ++new_offset;
9bbda503 2442 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
4c4b4cd2 2443 }
53ba8333
JB
2444 set_value_offset (v, new_offset);
2445
2446 /* Also set the parent value. This is needed when trying to
2447 assign a new value (in inferior memory). */
2448 set_value_parent (v, obj);
14f9c5c9
AS
2449 }
2450 else
9bbda503 2451 set_value_bitsize (v, bit_size);
0fd88904 2452 unpacked = (unsigned char *) value_contents (v);
14f9c5c9
AS
2453
2454 srcBitsLeft = bit_size;
2455 nsrc = len;
2456 ntarg = TYPE_LENGTH (type);
2457 sign = 0;
2458 if (bit_size == 0)
2459 {
2460 memset (unpacked, 0, TYPE_LENGTH (type));
2461 return v;
2462 }
50810684 2463 else if (gdbarch_bits_big_endian (get_type_arch (type)))
14f9c5c9 2464 {
d2e4a39e 2465 src = len - 1;
1265e4aa
JB
2466 if (has_negatives (type)
2467 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2468 sign = ~0;
d2e4a39e
AS
2469
2470 unusedLS =
4c4b4cd2
PH
2471 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2472 % HOST_CHAR_BIT;
14f9c5c9
AS
2473
2474 switch (TYPE_CODE (type))
4c4b4cd2
PH
2475 {
2476 case TYPE_CODE_ARRAY:
2477 case TYPE_CODE_UNION:
2478 case TYPE_CODE_STRUCT:
2479 /* Non-scalar values must be aligned at a byte boundary... */
2480 accumSize =
2481 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2482 /* ... And are placed at the beginning (most-significant) bytes
2483 of the target. */
529cad9c 2484 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
0056e4d5 2485 ntarg = targ + 1;
4c4b4cd2
PH
2486 break;
2487 default:
2488 accumSize = 0;
2489 targ = TYPE_LENGTH (type) - 1;
2490 break;
2491 }
14f9c5c9 2492 }
d2e4a39e 2493 else
14f9c5c9
AS
2494 {
2495 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2496
2497 src = targ = 0;
2498 unusedLS = bit_offset;
2499 accumSize = 0;
2500
d2e4a39e 2501 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2502 sign = ~0;
14f9c5c9 2503 }
d2e4a39e 2504
14f9c5c9
AS
2505 accum = 0;
2506 while (nsrc > 0)
2507 {
2508 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2509 part of the value. */
d2e4a39e 2510 unsigned int unusedMSMask =
4c4b4cd2
PH
2511 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2512 1;
2513 /* Sign-extend bits for this byte. */
14f9c5c9 2514 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2515
d2e4a39e 2516 accum |=
4c4b4cd2 2517 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2518 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2519 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2
PH
2520 {
2521 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2522 accumSize -= HOST_CHAR_BIT;
2523 accum >>= HOST_CHAR_BIT;
2524 ntarg -= 1;
2525 targ += delta;
2526 }
14f9c5c9
AS
2527 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2528 unusedLS = 0;
2529 nsrc -= 1;
2530 src += delta;
2531 }
2532 while (ntarg > 0)
2533 {
2534 accum |= sign << accumSize;
2535 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2536 accumSize -= HOST_CHAR_BIT;
2537 accum >>= HOST_CHAR_BIT;
2538 ntarg -= 1;
2539 targ += delta;
2540 }
2541
2542 return v;
2543}
d2e4a39e 2544
14f9c5c9
AS
2545/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2546 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2547 not overlap. */
14f9c5c9 2548static void
fc1a4b47 2549move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2550 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2551{
2552 unsigned int accum, mask;
2553 int accum_bits, chunk_size;
2554
2555 target += targ_offset / HOST_CHAR_BIT;
2556 targ_offset %= HOST_CHAR_BIT;
2557 source += src_offset / HOST_CHAR_BIT;
2558 src_offset %= HOST_CHAR_BIT;
50810684 2559 if (bits_big_endian_p)
14f9c5c9
AS
2560 {
2561 accum = (unsigned char) *source;
2562 source += 1;
2563 accum_bits = HOST_CHAR_BIT - src_offset;
2564
d2e4a39e 2565 while (n > 0)
4c4b4cd2
PH
2566 {
2567 int unused_right;
5b4ee69b 2568
4c4b4cd2
PH
2569 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2570 accum_bits += HOST_CHAR_BIT;
2571 source += 1;
2572 chunk_size = HOST_CHAR_BIT - targ_offset;
2573 if (chunk_size > n)
2574 chunk_size = n;
2575 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2576 mask = ((1 << chunk_size) - 1) << unused_right;
2577 *target =
2578 (*target & ~mask)
2579 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2580 n -= chunk_size;
2581 accum_bits -= chunk_size;
2582 target += 1;
2583 targ_offset = 0;
2584 }
14f9c5c9
AS
2585 }
2586 else
2587 {
2588 accum = (unsigned char) *source >> src_offset;
2589 source += 1;
2590 accum_bits = HOST_CHAR_BIT - src_offset;
2591
d2e4a39e 2592 while (n > 0)
4c4b4cd2
PH
2593 {
2594 accum = accum + ((unsigned char) *source << accum_bits);
2595 accum_bits += HOST_CHAR_BIT;
2596 source += 1;
2597 chunk_size = HOST_CHAR_BIT - targ_offset;
2598 if (chunk_size > n)
2599 chunk_size = n;
2600 mask = ((1 << chunk_size) - 1) << targ_offset;
2601 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2602 n -= chunk_size;
2603 accum_bits -= chunk_size;
2604 accum >>= chunk_size;
2605 target += 1;
2606 targ_offset = 0;
2607 }
14f9c5c9
AS
2608 }
2609}
2610
14f9c5c9
AS
2611/* Store the contents of FROMVAL into the location of TOVAL.
2612 Return a new value with the location of TOVAL and contents of
2613 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2614 floating-point or non-scalar types. */
14f9c5c9 2615
d2e4a39e
AS
2616static struct value *
2617ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2618{
df407dfe
AC
2619 struct type *type = value_type (toval);
2620 int bits = value_bitsize (toval);
14f9c5c9 2621
52ce6436
PH
2622 toval = ada_coerce_ref (toval);
2623 fromval = ada_coerce_ref (fromval);
2624
2625 if (ada_is_direct_array_type (value_type (toval)))
2626 toval = ada_coerce_to_simple_array (toval);
2627 if (ada_is_direct_array_type (value_type (fromval)))
2628 fromval = ada_coerce_to_simple_array (fromval);
2629
88e3b34b 2630 if (!deprecated_value_modifiable (toval))
323e0a4a 2631 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2632
d2e4a39e 2633 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2634 && bits > 0
d2e4a39e 2635 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2636 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2637 {
df407dfe
AC
2638 int len = (value_bitpos (toval)
2639 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2640 int from_size;
948f8e3d 2641 gdb_byte *buffer = alloca (len);
d2e4a39e 2642 struct value *val;
42ae5230 2643 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2644
2645 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2646 fromval = value_cast (type, fromval);
14f9c5c9 2647
52ce6436 2648 read_memory (to_addr, buffer, len);
aced2898
PH
2649 from_size = value_bitsize (fromval);
2650 if (from_size == 0)
2651 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2652 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2653 move_bits (buffer, value_bitpos (toval),
50810684 2654 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2655 else
50810684
UW
2656 move_bits (buffer, value_bitpos (toval),
2657 value_contents (fromval), 0, bits, 0);
972daa01 2658 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2659
14f9c5c9 2660 val = value_copy (toval);
0fd88904 2661 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2662 TYPE_LENGTH (type));
04624583 2663 deprecated_set_value_type (val, type);
d2e4a39e 2664
14f9c5c9
AS
2665 return val;
2666 }
2667
2668 return value_assign (toval, fromval);
2669}
2670
2671
52ce6436
PH
2672/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2673 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2674 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2675 * COMPONENT, and not the inferior's memory. The current contents
2676 * of COMPONENT are ignored. */
2677static void
2678value_assign_to_component (struct value *container, struct value *component,
2679 struct value *val)
2680{
2681 LONGEST offset_in_container =
42ae5230 2682 (LONGEST) (value_address (component) - value_address (container));
52ce6436
PH
2683 int bit_offset_in_container =
2684 value_bitpos (component) - value_bitpos (container);
2685 int bits;
2686
2687 val = value_cast (value_type (component), val);
2688
2689 if (value_bitsize (component) == 0)
2690 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2691 else
2692 bits = value_bitsize (component);
2693
50810684 2694 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
52ce6436
PH
2695 move_bits (value_contents_writeable (container) + offset_in_container,
2696 value_bitpos (container) + bit_offset_in_container,
2697 value_contents (val),
2698 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
50810684 2699 bits, 1);
52ce6436
PH
2700 else
2701 move_bits (value_contents_writeable (container) + offset_in_container,
2702 value_bitpos (container) + bit_offset_in_container,
50810684 2703 value_contents (val), 0, bits, 0);
52ce6436
PH
2704}
2705
4c4b4cd2
PH
2706/* The value of the element of array ARR at the ARITY indices given in IND.
2707 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2708 thereto. */
2709
d2e4a39e
AS
2710struct value *
2711ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2712{
2713 int k;
d2e4a39e
AS
2714 struct value *elt;
2715 struct type *elt_type;
14f9c5c9
AS
2716
2717 elt = ada_coerce_to_simple_array (arr);
2718
df407dfe 2719 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2720 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2721 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2722 return value_subscript_packed (elt, arity, ind);
2723
2724 for (k = 0; k < arity; k += 1)
2725 {
2726 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2727 error (_("too many subscripts (%d expected)"), k);
2497b498 2728 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2729 }
2730 return elt;
2731}
2732
deede10c
JB
2733/* Assuming ARR is a pointer to a GDB array, the value of the element
2734 of *ARR at the ARITY indices given in IND.
2735 Does not read the entire array into memory. */
14f9c5c9 2736
2c0b251b 2737static struct value *
deede10c 2738ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2739{
2740 int k;
deede10c
JB
2741 struct type *type
2742 = check_typedef (value_enclosing_type (ada_value_ind (arr)));
14f9c5c9
AS
2743
2744 for (k = 0; k < arity; k += 1)
2745 {
2746 LONGEST lwb, upb;
14f9c5c9
AS
2747
2748 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2749 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2750 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2751 value_copy (arr));
14f9c5c9 2752 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2497b498 2753 arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
14f9c5c9
AS
2754 type = TYPE_TARGET_TYPE (type);
2755 }
2756
2757 return value_ind (arr);
2758}
2759
0b5d8877 2760/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
f5938064
JG
2761 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2762 elements starting at index LOW. The lower bound of this array is LOW, as
0963b4bd 2763 per Ada rules. */
0b5d8877 2764static struct value *
f5938064
JG
2765ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2766 int low, int high)
0b5d8877 2767{
b0dd7688 2768 struct type *type0 = ada_check_typedef (type);
6c038f32 2769 CORE_ADDR base = value_as_address (array_ptr)
b0dd7688
JB
2770 + ((low - ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0)))
2771 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
0c9c3474
SA
2772 struct type *index_type
2773 = create_static_range_type (NULL,
2774 TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)),
2775 low, high);
6c038f32 2776 struct type *slice_type =
b0dd7688 2777 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
5b4ee69b 2778
f5938064 2779 return value_at_lazy (slice_type, base);
0b5d8877
PH
2780}
2781
2782
2783static struct value *
2784ada_value_slice (struct value *array, int low, int high)
2785{
b0dd7688 2786 struct type *type = ada_check_typedef (value_type (array));
0c9c3474
SA
2787 struct type *index_type
2788 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
6c038f32 2789 struct type *slice_type =
0b5d8877 2790 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
5b4ee69b 2791
6c038f32 2792 return value_cast (slice_type, value_slice (array, low, high - low + 1));
0b5d8877
PH
2793}
2794
14f9c5c9
AS
2795/* If type is a record type in the form of a standard GNAT array
2796 descriptor, returns the number of dimensions for type. If arr is a
2797 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2798 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2799
2800int
d2e4a39e 2801ada_array_arity (struct type *type)
14f9c5c9
AS
2802{
2803 int arity;
2804
2805 if (type == NULL)
2806 return 0;
2807
2808 type = desc_base_type (type);
2809
2810 arity = 0;
d2e4a39e 2811 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2812 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2813 else
2814 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2815 {
4c4b4cd2 2816 arity += 1;
61ee279c 2817 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2818 }
d2e4a39e 2819
14f9c5c9
AS
2820 return arity;
2821}
2822
2823/* If TYPE is a record type in the form of a standard GNAT array
2824 descriptor or a simple array type, returns the element type for
2825 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2826 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2827
d2e4a39e
AS
2828struct type *
2829ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2830{
2831 type = desc_base_type (type);
2832
d2e4a39e 2833 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2834 {
2835 int k;
d2e4a39e 2836 struct type *p_array_type;
14f9c5c9 2837
556bdfd4 2838 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
2839
2840 k = ada_array_arity (type);
2841 if (k == 0)
4c4b4cd2 2842 return NULL;
d2e4a39e 2843
4c4b4cd2 2844 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2845 if (nindices >= 0 && k > nindices)
4c4b4cd2 2846 k = nindices;
d2e4a39e 2847 while (k > 0 && p_array_type != NULL)
4c4b4cd2 2848 {
61ee279c 2849 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
2850 k -= 1;
2851 }
14f9c5c9
AS
2852 return p_array_type;
2853 }
2854 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2855 {
2856 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
2857 {
2858 type = TYPE_TARGET_TYPE (type);
2859 nindices -= 1;
2860 }
14f9c5c9
AS
2861 return type;
2862 }
2863
2864 return NULL;
2865}
2866
4c4b4cd2 2867/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
2868 Does not examine memory. Throws an error if N is invalid or TYPE
2869 is not an array type. NAME is the name of the Ada attribute being
2870 evaluated ('range, 'first, 'last, or 'length); it is used in building
2871 the error message. */
14f9c5c9 2872
1eea4ebd
UW
2873static struct type *
2874ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 2875{
4c4b4cd2
PH
2876 struct type *result_type;
2877
14f9c5c9
AS
2878 type = desc_base_type (type);
2879
1eea4ebd
UW
2880 if (n < 0 || n > ada_array_arity (type))
2881 error (_("invalid dimension number to '%s"), name);
14f9c5c9 2882
4c4b4cd2 2883 if (ada_is_simple_array_type (type))
14f9c5c9
AS
2884 {
2885 int i;
2886
2887 for (i = 1; i < n; i += 1)
4c4b4cd2 2888 type = TYPE_TARGET_TYPE (type);
262452ec 2889 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
2890 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2891 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 2892 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
2893 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2894 result_type = NULL;
14f9c5c9 2895 }
d2e4a39e 2896 else
1eea4ebd
UW
2897 {
2898 result_type = desc_index_type (desc_bounds_type (type), n);
2899 if (result_type == NULL)
2900 error (_("attempt to take bound of something that is not an array"));
2901 }
2902
2903 return result_type;
14f9c5c9
AS
2904}
2905
2906/* Given that arr is an array type, returns the lower bound of the
2907 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 2908 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
2909 array-descriptor type. It works for other arrays with bounds supplied
2910 by run-time quantities other than discriminants. */
14f9c5c9 2911
abb68b3e 2912static LONGEST
fb5e3d5c 2913ada_array_bound_from_type (struct type *arr_type, int n, int which)
14f9c5c9 2914{
8a48ac95 2915 struct type *type, *index_type_desc, *index_type;
1ce677a4 2916 int i;
262452ec
JK
2917
2918 gdb_assert (which == 0 || which == 1);
14f9c5c9 2919
ad82864c
JB
2920 if (ada_is_constrained_packed_array_type (arr_type))
2921 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 2922
4c4b4cd2 2923 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 2924 return (LONGEST) - which;
14f9c5c9
AS
2925
2926 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2927 type = TYPE_TARGET_TYPE (arr_type);
2928 else
2929 type = arr_type;
2930
2931 index_type_desc = ada_find_parallel_type (type, "___XA");
28c85d6c 2932 ada_fixup_array_indexes_type (index_type_desc);
262452ec 2933 if (index_type_desc != NULL)
28c85d6c
JB
2934 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
2935 NULL);
262452ec 2936 else
8a48ac95
JB
2937 {
2938 struct type *elt_type = check_typedef (type);
2939
2940 for (i = 1; i < n; i++)
2941 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
2942
2943 index_type = TYPE_INDEX_TYPE (elt_type);
2944 }
262452ec 2945
43bbcdc2
PH
2946 return
2947 (LONGEST) (which == 0
2948 ? ada_discrete_type_low_bound (index_type)
2949 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
2950}
2951
2952/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
2953 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2954 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 2955 supplied by run-time quantities other than discriminants. */
14f9c5c9 2956
1eea4ebd 2957static LONGEST
4dc81987 2958ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 2959{
eb479039
JB
2960 struct type *arr_type;
2961
2962 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
2963 arr = value_ind (arr);
2964 arr_type = value_enclosing_type (arr);
14f9c5c9 2965
ad82864c
JB
2966 if (ada_is_constrained_packed_array_type (arr_type))
2967 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 2968 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 2969 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 2970 else
1eea4ebd 2971 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
2972}
2973
2974/* Given that arr is an array value, returns the length of the
2975 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
2976 supplied by run-time quantities other than discriminants.
2977 Does not work for arrays indexed by enumeration types with representation
2978 clauses at the moment. */
14f9c5c9 2979
1eea4ebd 2980static LONGEST
d2e4a39e 2981ada_array_length (struct value *arr, int n)
14f9c5c9 2982{
eb479039
JB
2983 struct type *arr_type;
2984
2985 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
2986 arr = value_ind (arr);
2987 arr_type = value_enclosing_type (arr);
14f9c5c9 2988
ad82864c
JB
2989 if (ada_is_constrained_packed_array_type (arr_type))
2990 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 2991
4c4b4cd2 2992 if (ada_is_simple_array_type (arr_type))
1eea4ebd
UW
2993 return (ada_array_bound_from_type (arr_type, n, 1)
2994 - ada_array_bound_from_type (arr_type, n, 0) + 1);
14f9c5c9 2995 else
1eea4ebd
UW
2996 return (value_as_long (desc_one_bound (desc_bounds (arr), n, 1))
2997 - value_as_long (desc_one_bound (desc_bounds (arr), n, 0)) + 1);
4c4b4cd2
PH
2998}
2999
3000/* An empty array whose type is that of ARR_TYPE (an array type),
3001 with bounds LOW to LOW-1. */
3002
3003static struct value *
3004empty_array (struct type *arr_type, int low)
3005{
b0dd7688 3006 struct type *arr_type0 = ada_check_typedef (arr_type);
0c9c3474
SA
3007 struct type *index_type
3008 = create_static_range_type
3009 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
b0dd7688 3010 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 3011
0b5d8877 3012 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 3013}
14f9c5c9 3014\f
d2e4a39e 3015
4c4b4cd2 3016 /* Name resolution */
14f9c5c9 3017
4c4b4cd2
PH
3018/* The "decoded" name for the user-definable Ada operator corresponding
3019 to OP. */
14f9c5c9 3020
d2e4a39e 3021static const char *
4c4b4cd2 3022ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
3023{
3024 int i;
3025
4c4b4cd2 3026 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
3027 {
3028 if (ada_opname_table[i].op == op)
4c4b4cd2 3029 return ada_opname_table[i].decoded;
14f9c5c9 3030 }
323e0a4a 3031 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
3032}
3033
3034
4c4b4cd2
PH
3035/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3036 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3037 undefined namespace) and converts operators that are
3038 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
3039 non-null, it provides a preferred result type [at the moment, only
3040 type void has any effect---causing procedures to be preferred over
3041 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 3042 return type is preferred. May change (expand) *EXP. */
14f9c5c9 3043
4c4b4cd2
PH
3044static void
3045resolve (struct expression **expp, int void_context_p)
14f9c5c9 3046{
30b15541
UW
3047 struct type *context_type = NULL;
3048 int pc = 0;
3049
3050 if (void_context_p)
3051 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3052
3053 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
3054}
3055
4c4b4cd2
PH
3056/* Resolve the operator of the subexpression beginning at
3057 position *POS of *EXPP. "Resolving" consists of replacing
3058 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3059 with their resolutions, replacing built-in operators with
3060 function calls to user-defined operators, where appropriate, and,
3061 when DEPROCEDURE_P is non-zero, converting function-valued variables
3062 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3063 are as in ada_resolve, above. */
14f9c5c9 3064
d2e4a39e 3065static struct value *
4c4b4cd2 3066resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
76a01679 3067 struct type *context_type)
14f9c5c9
AS
3068{
3069 int pc = *pos;
3070 int i;
4c4b4cd2 3071 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 3072 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
3073 struct value **argvec; /* Vector of operand types (alloca'ed). */
3074 int nargs; /* Number of operands. */
52ce6436 3075 int oplen;
14f9c5c9
AS
3076
3077 argvec = NULL;
3078 nargs = 0;
3079 exp = *expp;
3080
52ce6436
PH
3081 /* Pass one: resolve operands, saving their types and updating *pos,
3082 if needed. */
14f9c5c9
AS
3083 switch (op)
3084 {
4c4b4cd2
PH
3085 case OP_FUNCALL:
3086 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
3087 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3088 *pos += 7;
4c4b4cd2
PH
3089 else
3090 {
3091 *pos += 3;
3092 resolve_subexp (expp, pos, 0, NULL);
3093 }
3094 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
3095 break;
3096
14f9c5c9 3097 case UNOP_ADDR:
4c4b4cd2
PH
3098 *pos += 1;
3099 resolve_subexp (expp, pos, 0, NULL);
3100 break;
3101
52ce6436
PH
3102 case UNOP_QUAL:
3103 *pos += 3;
17466c1a 3104 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
3105 break;
3106
52ce6436 3107 case OP_ATR_MODULUS:
4c4b4cd2
PH
3108 case OP_ATR_SIZE:
3109 case OP_ATR_TAG:
4c4b4cd2
PH
3110 case OP_ATR_FIRST:
3111 case OP_ATR_LAST:
3112 case OP_ATR_LENGTH:
3113 case OP_ATR_POS:
3114 case OP_ATR_VAL:
4c4b4cd2
PH
3115 case OP_ATR_MIN:
3116 case OP_ATR_MAX:
52ce6436
PH
3117 case TERNOP_IN_RANGE:
3118 case BINOP_IN_BOUNDS:
3119 case UNOP_IN_RANGE:
3120 case OP_AGGREGATE:
3121 case OP_OTHERS:
3122 case OP_CHOICES:
3123 case OP_POSITIONAL:
3124 case OP_DISCRETE_RANGE:
3125 case OP_NAME:
3126 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3127 *pos += oplen;
14f9c5c9
AS
3128 break;
3129
3130 case BINOP_ASSIGN:
3131 {
4c4b4cd2
PH
3132 struct value *arg1;
3133
3134 *pos += 1;
3135 arg1 = resolve_subexp (expp, pos, 0, NULL);
3136 if (arg1 == NULL)
3137 resolve_subexp (expp, pos, 1, NULL);
3138 else
df407dfe 3139 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 3140 break;
14f9c5c9
AS
3141 }
3142
4c4b4cd2 3143 case UNOP_CAST:
4c4b4cd2
PH
3144 *pos += 3;
3145 nargs = 1;
3146 break;
14f9c5c9 3147
4c4b4cd2
PH
3148 case BINOP_ADD:
3149 case BINOP_SUB:
3150 case BINOP_MUL:
3151 case BINOP_DIV:
3152 case BINOP_REM:
3153 case BINOP_MOD:
3154 case BINOP_EXP:
3155 case BINOP_CONCAT:
3156 case BINOP_LOGICAL_AND:
3157 case BINOP_LOGICAL_OR:
3158 case BINOP_BITWISE_AND:
3159 case BINOP_BITWISE_IOR:
3160 case BINOP_BITWISE_XOR:
14f9c5c9 3161
4c4b4cd2
PH
3162 case BINOP_EQUAL:
3163 case BINOP_NOTEQUAL:
3164 case BINOP_LESS:
3165 case BINOP_GTR:
3166 case BINOP_LEQ:
3167 case BINOP_GEQ:
14f9c5c9 3168
4c4b4cd2
PH
3169 case BINOP_REPEAT:
3170 case BINOP_SUBSCRIPT:
3171 case BINOP_COMMA:
40c8aaa9
JB
3172 *pos += 1;
3173 nargs = 2;
3174 break;
14f9c5c9 3175
4c4b4cd2
PH
3176 case UNOP_NEG:
3177 case UNOP_PLUS:
3178 case UNOP_LOGICAL_NOT:
3179 case UNOP_ABS:
3180 case UNOP_IND:
3181 *pos += 1;
3182 nargs = 1;
3183 break;
14f9c5c9 3184
4c4b4cd2
PH
3185 case OP_LONG:
3186 case OP_DOUBLE:
3187 case OP_VAR_VALUE:
3188 *pos += 4;
3189 break;
14f9c5c9 3190
4c4b4cd2
PH
3191 case OP_TYPE:
3192 case OP_BOOL:
3193 case OP_LAST:
4c4b4cd2
PH
3194 case OP_INTERNALVAR:
3195 *pos += 3;
3196 break;
14f9c5c9 3197
4c4b4cd2
PH
3198 case UNOP_MEMVAL:
3199 *pos += 3;
3200 nargs = 1;
3201 break;
3202
67f3407f
DJ
3203 case OP_REGISTER:
3204 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3205 break;
3206
4c4b4cd2
PH
3207 case STRUCTOP_STRUCT:
3208 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3209 nargs = 1;
3210 break;
3211
4c4b4cd2 3212 case TERNOP_SLICE:
4c4b4cd2
PH
3213 *pos += 1;
3214 nargs = 3;
3215 break;
3216
52ce6436 3217 case OP_STRING:
14f9c5c9 3218 break;
4c4b4cd2
PH
3219
3220 default:
323e0a4a 3221 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3222 }
3223
76a01679 3224 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
4c4b4cd2
PH
3225 for (i = 0; i < nargs; i += 1)
3226 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3227 argvec[i] = NULL;
3228 exp = *expp;
3229
3230 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3231 switch (op)
3232 {
3233 default:
3234 break;
3235
14f9c5c9 3236 case OP_VAR_VALUE:
4c4b4cd2 3237 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
3238 {
3239 struct ada_symbol_info *candidates;
3240 int n_candidates;
3241
3242 n_candidates =
3243 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3244 (exp->elts[pc + 2].symbol),
3245 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3246 &candidates);
76a01679
JB
3247
3248 if (n_candidates > 1)
3249 {
3250 /* Types tend to get re-introduced locally, so if there
3251 are any local symbols that are not types, first filter
3252 out all types. */
3253 int j;
3254 for (j = 0; j < n_candidates; j += 1)
3255 switch (SYMBOL_CLASS (candidates[j].sym))
3256 {
3257 case LOC_REGISTER:
3258 case LOC_ARG:
3259 case LOC_REF_ARG:
76a01679
JB
3260 case LOC_REGPARM_ADDR:
3261 case LOC_LOCAL:
76a01679 3262 case LOC_COMPUTED:
76a01679
JB
3263 goto FoundNonType;
3264 default:
3265 break;
3266 }
3267 FoundNonType:
3268 if (j < n_candidates)
3269 {
3270 j = 0;
3271 while (j < n_candidates)
3272 {
3273 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
3274 {
3275 candidates[j] = candidates[n_candidates - 1];
3276 n_candidates -= 1;
3277 }
3278 else
3279 j += 1;
3280 }
3281 }
3282 }
3283
3284 if (n_candidates == 0)
323e0a4a 3285 error (_("No definition found for %s"),
76a01679
JB
3286 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3287 else if (n_candidates == 1)
3288 i = 0;
3289 else if (deprocedure_p
3290 && !is_nonfunction (candidates, n_candidates))
3291 {
06d5cf63
JB
3292 i = ada_resolve_function
3293 (candidates, n_candidates, NULL, 0,
3294 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3295 context_type);
76a01679 3296 if (i < 0)
323e0a4a 3297 error (_("Could not find a match for %s"),
76a01679
JB
3298 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3299 }
3300 else
3301 {
323e0a4a 3302 printf_filtered (_("Multiple matches for %s\n"),
76a01679
JB
3303 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3304 user_select_syms (candidates, n_candidates, 1);
3305 i = 0;
3306 }
3307
3308 exp->elts[pc + 1].block = candidates[i].block;
3309 exp->elts[pc + 2].symbol = candidates[i].sym;
1265e4aa
JB
3310 if (innermost_block == NULL
3311 || contained_in (candidates[i].block, innermost_block))
76a01679
JB
3312 innermost_block = candidates[i].block;
3313 }
3314
3315 if (deprocedure_p
3316 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3317 == TYPE_CODE_FUNC))
3318 {
3319 replace_operator_with_call (expp, pc, 0, 0,
3320 exp->elts[pc + 2].symbol,
3321 exp->elts[pc + 1].block);
3322 exp = *expp;
3323 }
14f9c5c9
AS
3324 break;
3325
3326 case OP_FUNCALL:
3327 {
4c4b4cd2 3328 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3329 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2
PH
3330 {
3331 struct ada_symbol_info *candidates;
3332 int n_candidates;
3333
3334 n_candidates =
76a01679
JB
3335 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3336 (exp->elts[pc + 5].symbol),
3337 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3338 &candidates);
4c4b4cd2
PH
3339 if (n_candidates == 1)
3340 i = 0;
3341 else
3342 {
06d5cf63
JB
3343 i = ada_resolve_function
3344 (candidates, n_candidates,
3345 argvec, nargs,
3346 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3347 context_type);
4c4b4cd2 3348 if (i < 0)
323e0a4a 3349 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3350 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3351 }
3352
3353 exp->elts[pc + 4].block = candidates[i].block;
3354 exp->elts[pc + 5].symbol = candidates[i].sym;
1265e4aa
JB
3355 if (innermost_block == NULL
3356 || contained_in (candidates[i].block, innermost_block))
4c4b4cd2
PH
3357 innermost_block = candidates[i].block;
3358 }
14f9c5c9
AS
3359 }
3360 break;
3361 case BINOP_ADD:
3362 case BINOP_SUB:
3363 case BINOP_MUL:
3364 case BINOP_DIV:
3365 case BINOP_REM:
3366 case BINOP_MOD:
3367 case BINOP_CONCAT:
3368 case BINOP_BITWISE_AND:
3369 case BINOP_BITWISE_IOR:
3370 case BINOP_BITWISE_XOR:
3371 case BINOP_EQUAL:
3372 case BINOP_NOTEQUAL:
3373 case BINOP_LESS:
3374 case BINOP_GTR:
3375 case BINOP_LEQ:
3376 case BINOP_GEQ:
3377 case BINOP_EXP:
3378 case UNOP_NEG:
3379 case UNOP_PLUS:
3380 case UNOP_LOGICAL_NOT:
3381 case UNOP_ABS:
3382 if (possible_user_operator_p (op, argvec))
4c4b4cd2
PH
3383 {
3384 struct ada_symbol_info *candidates;
3385 int n_candidates;
3386
3387 n_candidates =
3388 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3389 (struct block *) NULL, VAR_DOMAIN,
4eeaa230 3390 &candidates);
4c4b4cd2 3391 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
76a01679 3392 ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3393 if (i < 0)
3394 break;
3395
76a01679
JB
3396 replace_operator_with_call (expp, pc, nargs, 1,
3397 candidates[i].sym, candidates[i].block);
4c4b4cd2
PH
3398 exp = *expp;
3399 }
14f9c5c9 3400 break;
4c4b4cd2
PH
3401
3402 case OP_TYPE:
b3dbf008 3403 case OP_REGISTER:
4c4b4cd2 3404 return NULL;
14f9c5c9
AS
3405 }
3406
3407 *pos = pc;
3408 return evaluate_subexp_type (exp, pos);
3409}
3410
3411/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3412 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3413 a non-pointer. */
14f9c5c9 3414/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3415 liberal. */
14f9c5c9
AS
3416
3417static int
4dc81987 3418ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3419{
61ee279c
PH
3420 ftype = ada_check_typedef (ftype);
3421 atype = ada_check_typedef (atype);
14f9c5c9
AS
3422
3423 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3424 ftype = TYPE_TARGET_TYPE (ftype);
3425 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3426 atype = TYPE_TARGET_TYPE (atype);
3427
d2e4a39e 3428 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3429 {
3430 default:
5b3d5b7d 3431 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3432 case TYPE_CODE_PTR:
3433 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3434 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3435 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3436 else
1265e4aa
JB
3437 return (may_deref
3438 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3439 case TYPE_CODE_INT:
3440 case TYPE_CODE_ENUM:
3441 case TYPE_CODE_RANGE:
3442 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3443 {
3444 case TYPE_CODE_INT:
3445 case TYPE_CODE_ENUM:
3446 case TYPE_CODE_RANGE:
3447 return 1;
3448 default:
3449 return 0;
3450 }
14f9c5c9
AS
3451
3452 case TYPE_CODE_ARRAY:
d2e4a39e 3453 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3454 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3455
3456 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3457 if (ada_is_array_descriptor_type (ftype))
3458 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3459 || ada_is_array_descriptor_type (atype));
14f9c5c9 3460 else
4c4b4cd2
PH
3461 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3462 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3463
3464 case TYPE_CODE_UNION:
3465 case TYPE_CODE_FLT:
3466 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3467 }
3468}
3469
3470/* Return non-zero if the formals of FUNC "sufficiently match" the
3471 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3472 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3473 argument function. */
14f9c5c9
AS
3474
3475static int
d2e4a39e 3476ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3477{
3478 int i;
d2e4a39e 3479 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3480
1265e4aa
JB
3481 if (SYMBOL_CLASS (func) == LOC_CONST
3482 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3483 return (n_actuals == 0);
3484 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3485 return 0;
3486
3487 if (TYPE_NFIELDS (func_type) != n_actuals)
3488 return 0;
3489
3490 for (i = 0; i < n_actuals; i += 1)
3491 {
4c4b4cd2 3492 if (actuals[i] == NULL)
76a01679
JB
3493 return 0;
3494 else
3495 {
5b4ee69b
MS
3496 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3497 i));
df407dfe 3498 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3499
76a01679
JB
3500 if (!ada_type_match (ftype, atype, 1))
3501 return 0;
3502 }
14f9c5c9
AS
3503 }
3504 return 1;
3505}
3506
3507/* False iff function type FUNC_TYPE definitely does not produce a value
3508 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3509 FUNC_TYPE is not a valid function type with a non-null return type
3510 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3511
3512static int
d2e4a39e 3513return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3514{
d2e4a39e 3515 struct type *return_type;
14f9c5c9
AS
3516
3517 if (func_type == NULL)
3518 return 1;
3519
4c4b4cd2 3520 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3521 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3522 else
18af8284 3523 return_type = get_base_type (func_type);
14f9c5c9
AS
3524 if (return_type == NULL)
3525 return 1;
3526
18af8284 3527 context_type = get_base_type (context_type);
14f9c5c9
AS
3528
3529 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3530 return context_type == NULL || return_type == context_type;
3531 else if (context_type == NULL)
3532 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3533 else
3534 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3535}
3536
3537
4c4b4cd2 3538/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3539 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3540 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3541 that returns that type, then eliminate matches that don't. If
3542 CONTEXT_TYPE is void and there is at least one match that does not
3543 return void, eliminate all matches that do.
3544
14f9c5c9
AS
3545 Asks the user if there is more than one match remaining. Returns -1
3546 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3547 solely for messages. May re-arrange and modify SYMS in
3548 the process; the index returned is for the modified vector. */
14f9c5c9 3549
4c4b4cd2
PH
3550static int
3551ada_resolve_function (struct ada_symbol_info syms[],
3552 int nsyms, struct value **args, int nargs,
3553 const char *name, struct type *context_type)
14f9c5c9 3554{
30b15541 3555 int fallback;
14f9c5c9 3556 int k;
4c4b4cd2 3557 int m; /* Number of hits */
14f9c5c9 3558
d2e4a39e 3559 m = 0;
30b15541
UW
3560 /* In the first pass of the loop, we only accept functions matching
3561 context_type. If none are found, we add a second pass of the loop
3562 where every function is accepted. */
3563 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3564 {
3565 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3566 {
61ee279c 3567 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
4c4b4cd2
PH
3568
3569 if (ada_args_match (syms[k].sym, args, nargs)
30b15541 3570 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3571 {
3572 syms[m] = syms[k];
3573 m += 1;
3574 }
3575 }
14f9c5c9
AS
3576 }
3577
3578 if (m == 0)
3579 return -1;
3580 else if (m > 1)
3581 {
323e0a4a 3582 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3583 user_select_syms (syms, m, 1);
14f9c5c9
AS
3584 return 0;
3585 }
3586 return 0;
3587}
3588
4c4b4cd2
PH
3589/* Returns true (non-zero) iff decoded name N0 should appear before N1
3590 in a listing of choices during disambiguation (see sort_choices, below).
3591 The idea is that overloadings of a subprogram name from the
3592 same package should sort in their source order. We settle for ordering
3593 such symbols by their trailing number (__N or $N). */
3594
14f9c5c9 3595static int
0d5cff50 3596encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3597{
3598 if (N1 == NULL)
3599 return 0;
3600 else if (N0 == NULL)
3601 return 1;
3602 else
3603 {
3604 int k0, k1;
5b4ee69b 3605
d2e4a39e 3606 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3607 ;
d2e4a39e 3608 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3609 ;
d2e4a39e 3610 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3611 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3612 {
3613 int n0, n1;
5b4ee69b 3614
4c4b4cd2
PH
3615 n0 = k0;
3616 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3617 n0 -= 1;
3618 n1 = k1;
3619 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3620 n1 -= 1;
3621 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3622 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3623 }
14f9c5c9
AS
3624 return (strcmp (N0, N1) < 0);
3625 }
3626}
d2e4a39e 3627
4c4b4cd2
PH
3628/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3629 encoded names. */
3630
d2e4a39e 3631static void
4c4b4cd2 3632sort_choices (struct ada_symbol_info syms[], int nsyms)
14f9c5c9 3633{
4c4b4cd2 3634 int i;
5b4ee69b 3635
d2e4a39e 3636 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3637 {
4c4b4cd2 3638 struct ada_symbol_info sym = syms[i];
14f9c5c9
AS
3639 int j;
3640
d2e4a39e 3641 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2
PH
3642 {
3643 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3644 SYMBOL_LINKAGE_NAME (sym.sym)))
3645 break;
3646 syms[j + 1] = syms[j];
3647 }
d2e4a39e 3648 syms[j + 1] = sym;
14f9c5c9
AS
3649 }
3650}
3651
4c4b4cd2
PH
3652/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3653 by asking the user (if necessary), returning the number selected,
3654 and setting the first elements of SYMS items. Error if no symbols
3655 selected. */
14f9c5c9
AS
3656
3657/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3658 to be re-integrated one of these days. */
14f9c5c9
AS
3659
3660int
4c4b4cd2 3661user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
14f9c5c9
AS
3662{
3663 int i;
d2e4a39e 3664 int *chosen = (int *) alloca (sizeof (int) * nsyms);
14f9c5c9
AS
3665 int n_chosen;
3666 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3667 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3668
3669 if (max_results < 1)
323e0a4a 3670 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3671 if (nsyms <= 1)
3672 return nsyms;
3673
717d2f5a
JB
3674 if (select_mode == multiple_symbols_cancel)
3675 error (_("\
3676canceled because the command is ambiguous\n\
3677See set/show multiple-symbol."));
3678
3679 /* If select_mode is "all", then return all possible symbols.
3680 Only do that if more than one symbol can be selected, of course.
3681 Otherwise, display the menu as usual. */
3682 if (select_mode == multiple_symbols_all && max_results > 1)
3683 return nsyms;
3684
323e0a4a 3685 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3686 if (max_results > 1)
323e0a4a 3687 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3688
4c4b4cd2 3689 sort_choices (syms, nsyms);
14f9c5c9
AS
3690
3691 for (i = 0; i < nsyms; i += 1)
3692 {
4c4b4cd2
PH
3693 if (syms[i].sym == NULL)
3694 continue;
3695
3696 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3697 {
76a01679
JB
3698 struct symtab_and_line sal =
3699 find_function_start_sal (syms[i].sym, 1);
5b4ee69b 3700
323e0a4a
AC
3701 if (sal.symtab == NULL)
3702 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3703 i + first_choice,
3704 SYMBOL_PRINT_NAME (syms[i].sym),
3705 sal.line);
3706 else
3707 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3708 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821
JK
3709 symtab_to_filename_for_display (sal.symtab),
3710 sal.line);
4c4b4cd2
PH
3711 continue;
3712 }
d2e4a39e 3713 else
4c4b4cd2
PH
3714 {
3715 int is_enumeral =
3716 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3717 && SYMBOL_TYPE (syms[i].sym) != NULL
3718 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
210bbc17 3719 struct symtab *symtab = SYMBOL_SYMTAB (syms[i].sym);
4c4b4cd2
PH
3720
3721 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
323e0a4a 3722 printf_unfiltered (_("[%d] %s at %s:%d\n"),
4c4b4cd2
PH
3723 i + first_choice,
3724 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821
JK
3725 symtab_to_filename_for_display (symtab),
3726 SYMBOL_LINE (syms[i].sym));
76a01679
JB
3727 else if (is_enumeral
3728 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
4c4b4cd2 3729 {
a3f17187 3730 printf_unfiltered (("[%d] "), i + first_choice);
76a01679 3731 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
79d43c61 3732 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3733 printf_unfiltered (_("'(%s) (enumeral)\n"),
4c4b4cd2
PH
3734 SYMBOL_PRINT_NAME (syms[i].sym));
3735 }
3736 else if (symtab != NULL)
3737 printf_unfiltered (is_enumeral
323e0a4a
AC
3738 ? _("[%d] %s in %s (enumeral)\n")
3739 : _("[%d] %s at %s:?\n"),
4c4b4cd2
PH
3740 i + first_choice,
3741 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821 3742 symtab_to_filename_for_display (symtab));
4c4b4cd2
PH
3743 else
3744 printf_unfiltered (is_enumeral
323e0a4a
AC
3745 ? _("[%d] %s (enumeral)\n")
3746 : _("[%d] %s at ?\n"),
4c4b4cd2
PH
3747 i + first_choice,
3748 SYMBOL_PRINT_NAME (syms[i].sym));
3749 }
14f9c5c9 3750 }
d2e4a39e 3751
14f9c5c9 3752 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 3753 "overload-choice");
14f9c5c9
AS
3754
3755 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 3756 syms[i] = syms[chosen[i]];
14f9c5c9
AS
3757
3758 return n_chosen;
3759}
3760
3761/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 3762 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
3763 order in CHOICES[0 .. N-1], and return N.
3764
3765 The user types choices as a sequence of numbers on one line
3766 separated by blanks, encoding them as follows:
3767
4c4b4cd2 3768 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
3769 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3770 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3771
4c4b4cd2 3772 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
3773
3774 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 3775 prompts (for use with the -f switch). */
14f9c5c9
AS
3776
3777int
d2e4a39e 3778get_selections (int *choices, int n_choices, int max_results,
4c4b4cd2 3779 int is_all_choice, char *annotation_suffix)
14f9c5c9 3780{
d2e4a39e 3781 char *args;
0bcd0149 3782 char *prompt;
14f9c5c9
AS
3783 int n_chosen;
3784 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 3785
14f9c5c9
AS
3786 prompt = getenv ("PS2");
3787 if (prompt == NULL)
0bcd0149 3788 prompt = "> ";
14f9c5c9 3789
0bcd0149 3790 args = command_line_input (prompt, 0, annotation_suffix);
d2e4a39e 3791
14f9c5c9 3792 if (args == NULL)
323e0a4a 3793 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
3794
3795 n_chosen = 0;
76a01679 3796
4c4b4cd2
PH
3797 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3798 order, as given in args. Choices are validated. */
14f9c5c9
AS
3799 while (1)
3800 {
d2e4a39e 3801 char *args2;
14f9c5c9
AS
3802 int choice, j;
3803
0fcd72ba 3804 args = skip_spaces (args);
14f9c5c9 3805 if (*args == '\0' && n_chosen == 0)
323e0a4a 3806 error_no_arg (_("one or more choice numbers"));
14f9c5c9 3807 else if (*args == '\0')
4c4b4cd2 3808 break;
14f9c5c9
AS
3809
3810 choice = strtol (args, &args2, 10);
d2e4a39e 3811 if (args == args2 || choice < 0
4c4b4cd2 3812 || choice > n_choices + first_choice - 1)
323e0a4a 3813 error (_("Argument must be choice number"));
14f9c5c9
AS
3814 args = args2;
3815
d2e4a39e 3816 if (choice == 0)
323e0a4a 3817 error (_("cancelled"));
14f9c5c9
AS
3818
3819 if (choice < first_choice)
4c4b4cd2
PH
3820 {
3821 n_chosen = n_choices;
3822 for (j = 0; j < n_choices; j += 1)
3823 choices[j] = j;
3824 break;
3825 }
14f9c5c9
AS
3826 choice -= first_choice;
3827
d2e4a39e 3828 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
3829 {
3830 }
14f9c5c9
AS
3831
3832 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
3833 {
3834 int k;
5b4ee69b 3835
4c4b4cd2
PH
3836 for (k = n_chosen - 1; k > j; k -= 1)
3837 choices[k + 1] = choices[k];
3838 choices[j + 1] = choice;
3839 n_chosen += 1;
3840 }
14f9c5c9
AS
3841 }
3842
3843 if (n_chosen > max_results)
323e0a4a 3844 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 3845
14f9c5c9
AS
3846 return n_chosen;
3847}
3848
4c4b4cd2
PH
3849/* Replace the operator of length OPLEN at position PC in *EXPP with a call
3850 on the function identified by SYM and BLOCK, and taking NARGS
3851 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
3852
3853static void
d2e4a39e 3854replace_operator_with_call (struct expression **expp, int pc, int nargs,
4c4b4cd2 3855 int oplen, struct symbol *sym,
270140bd 3856 const struct block *block)
14f9c5c9
AS
3857{
3858 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 3859 symbol, -oplen for operator being replaced). */
d2e4a39e 3860 struct expression *newexp = (struct expression *)
8c1a34e7 3861 xzalloc (sizeof (struct expression)
4c4b4cd2 3862 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
d2e4a39e 3863 struct expression *exp = *expp;
14f9c5c9
AS
3864
3865 newexp->nelts = exp->nelts + 7 - oplen;
3866 newexp->language_defn = exp->language_defn;
3489610d 3867 newexp->gdbarch = exp->gdbarch;
14f9c5c9 3868 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 3869 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 3870 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
3871
3872 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3873 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3874
3875 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3876 newexp->elts[pc + 4].block = block;
3877 newexp->elts[pc + 5].symbol = sym;
3878
3879 *expp = newexp;
aacb1f0a 3880 xfree (exp);
d2e4a39e 3881}
14f9c5c9
AS
3882
3883/* Type-class predicates */
3884
4c4b4cd2
PH
3885/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3886 or FLOAT). */
14f9c5c9
AS
3887
3888static int
d2e4a39e 3889numeric_type_p (struct type *type)
14f9c5c9
AS
3890{
3891 if (type == NULL)
3892 return 0;
d2e4a39e
AS
3893 else
3894 {
3895 switch (TYPE_CODE (type))
4c4b4cd2
PH
3896 {
3897 case TYPE_CODE_INT:
3898 case TYPE_CODE_FLT:
3899 return 1;
3900 case TYPE_CODE_RANGE:
3901 return (type == TYPE_TARGET_TYPE (type)
3902 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3903 default:
3904 return 0;
3905 }
d2e4a39e 3906 }
14f9c5c9
AS
3907}
3908
4c4b4cd2 3909/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
3910
3911static int
d2e4a39e 3912integer_type_p (struct type *type)
14f9c5c9
AS
3913{
3914 if (type == NULL)
3915 return 0;
d2e4a39e
AS
3916 else
3917 {
3918 switch (TYPE_CODE (type))
4c4b4cd2
PH
3919 {
3920 case TYPE_CODE_INT:
3921 return 1;
3922 case TYPE_CODE_RANGE:
3923 return (type == TYPE_TARGET_TYPE (type)
3924 || integer_type_p (TYPE_TARGET_TYPE (type)));
3925 default:
3926 return 0;
3927 }
d2e4a39e 3928 }
14f9c5c9
AS
3929}
3930
4c4b4cd2 3931/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
3932
3933static int
d2e4a39e 3934scalar_type_p (struct type *type)
14f9c5c9
AS
3935{
3936 if (type == NULL)
3937 return 0;
d2e4a39e
AS
3938 else
3939 {
3940 switch (TYPE_CODE (type))
4c4b4cd2
PH
3941 {
3942 case TYPE_CODE_INT:
3943 case TYPE_CODE_RANGE:
3944 case TYPE_CODE_ENUM:
3945 case TYPE_CODE_FLT:
3946 return 1;
3947 default:
3948 return 0;
3949 }
d2e4a39e 3950 }
14f9c5c9
AS
3951}
3952
4c4b4cd2 3953/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
3954
3955static int
d2e4a39e 3956discrete_type_p (struct type *type)
14f9c5c9
AS
3957{
3958 if (type == NULL)
3959 return 0;
d2e4a39e
AS
3960 else
3961 {
3962 switch (TYPE_CODE (type))
4c4b4cd2
PH
3963 {
3964 case TYPE_CODE_INT:
3965 case TYPE_CODE_RANGE:
3966 case TYPE_CODE_ENUM:
872f0337 3967 case TYPE_CODE_BOOL:
4c4b4cd2
PH
3968 return 1;
3969 default:
3970 return 0;
3971 }
d2e4a39e 3972 }
14f9c5c9
AS
3973}
3974
4c4b4cd2
PH
3975/* Returns non-zero if OP with operands in the vector ARGS could be
3976 a user-defined function. Errs on the side of pre-defined operators
3977 (i.e., result 0). */
14f9c5c9
AS
3978
3979static int
d2e4a39e 3980possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 3981{
76a01679 3982 struct type *type0 =
df407dfe 3983 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 3984 struct type *type1 =
df407dfe 3985 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 3986
4c4b4cd2
PH
3987 if (type0 == NULL)
3988 return 0;
3989
14f9c5c9
AS
3990 switch (op)
3991 {
3992 default:
3993 return 0;
3994
3995 case BINOP_ADD:
3996 case BINOP_SUB:
3997 case BINOP_MUL:
3998 case BINOP_DIV:
d2e4a39e 3999 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
4000
4001 case BINOP_REM:
4002 case BINOP_MOD:
4003 case BINOP_BITWISE_AND:
4004 case BINOP_BITWISE_IOR:
4005 case BINOP_BITWISE_XOR:
d2e4a39e 4006 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4007
4008 case BINOP_EQUAL:
4009 case BINOP_NOTEQUAL:
4010 case BINOP_LESS:
4011 case BINOP_GTR:
4012 case BINOP_LEQ:
4013 case BINOP_GEQ:
d2e4a39e 4014 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
4015
4016 case BINOP_CONCAT:
ee90b9ab 4017 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
4018
4019 case BINOP_EXP:
d2e4a39e 4020 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4021
4022 case UNOP_NEG:
4023 case UNOP_PLUS:
4024 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
4025 case UNOP_ABS:
4026 return (!numeric_type_p (type0));
14f9c5c9
AS
4027
4028 }
4029}
4030\f
4c4b4cd2 4031 /* Renaming */
14f9c5c9 4032
aeb5907d
JB
4033/* NOTES:
4034
4035 1. In the following, we assume that a renaming type's name may
4036 have an ___XD suffix. It would be nice if this went away at some
4037 point.
4038 2. We handle both the (old) purely type-based representation of
4039 renamings and the (new) variable-based encoding. At some point,
4040 it is devoutly to be hoped that the former goes away
4041 (FIXME: hilfinger-2007-07-09).
4042 3. Subprogram renamings are not implemented, although the XRS
4043 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4044
4045/* If SYM encodes a renaming,
4046
4047 <renaming> renames <renamed entity>,
4048
4049 sets *LEN to the length of the renamed entity's name,
4050 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4051 the string describing the subcomponent selected from the renamed
0963b4bd 4052 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
4053 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4054 are undefined). Otherwise, returns a value indicating the category
4055 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4056 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4057 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4058 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4059 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4060 may be NULL, in which case they are not assigned.
4061
4062 [Currently, however, GCC does not generate subprogram renamings.] */
4063
4064enum ada_renaming_category
4065ada_parse_renaming (struct symbol *sym,
4066 const char **renamed_entity, int *len,
4067 const char **renaming_expr)
4068{
4069 enum ada_renaming_category kind;
4070 const char *info;
4071 const char *suffix;
4072
4073 if (sym == NULL)
4074 return ADA_NOT_RENAMING;
4075 switch (SYMBOL_CLASS (sym))
14f9c5c9 4076 {
aeb5907d
JB
4077 default:
4078 return ADA_NOT_RENAMING;
4079 case LOC_TYPEDEF:
4080 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4081 renamed_entity, len, renaming_expr);
4082 case LOC_LOCAL:
4083 case LOC_STATIC:
4084 case LOC_COMPUTED:
4085 case LOC_OPTIMIZED_OUT:
4086 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4087 if (info == NULL)
4088 return ADA_NOT_RENAMING;
4089 switch (info[5])
4090 {
4091 case '_':
4092 kind = ADA_OBJECT_RENAMING;
4093 info += 6;
4094 break;
4095 case 'E':
4096 kind = ADA_EXCEPTION_RENAMING;
4097 info += 7;
4098 break;
4099 case 'P':
4100 kind = ADA_PACKAGE_RENAMING;
4101 info += 7;
4102 break;
4103 case 'S':
4104 kind = ADA_SUBPROGRAM_RENAMING;
4105 info += 7;
4106 break;
4107 default:
4108 return ADA_NOT_RENAMING;
4109 }
14f9c5c9 4110 }
4c4b4cd2 4111
aeb5907d
JB
4112 if (renamed_entity != NULL)
4113 *renamed_entity = info;
4114 suffix = strstr (info, "___XE");
4115 if (suffix == NULL || suffix == info)
4116 return ADA_NOT_RENAMING;
4117 if (len != NULL)
4118 *len = strlen (info) - strlen (suffix);
4119 suffix += 5;
4120 if (renaming_expr != NULL)
4121 *renaming_expr = suffix;
4122 return kind;
4123}
4124
4125/* Assuming TYPE encodes a renaming according to the old encoding in
4126 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4127 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4128 ADA_NOT_RENAMING otherwise. */
4129static enum ada_renaming_category
4130parse_old_style_renaming (struct type *type,
4131 const char **renamed_entity, int *len,
4132 const char **renaming_expr)
4133{
4134 enum ada_renaming_category kind;
4135 const char *name;
4136 const char *info;
4137 const char *suffix;
14f9c5c9 4138
aeb5907d
JB
4139 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4140 || TYPE_NFIELDS (type) != 1)
4141 return ADA_NOT_RENAMING;
14f9c5c9 4142
aeb5907d
JB
4143 name = type_name_no_tag (type);
4144 if (name == NULL)
4145 return ADA_NOT_RENAMING;
4146
4147 name = strstr (name, "___XR");
4148 if (name == NULL)
4149 return ADA_NOT_RENAMING;
4150 switch (name[5])
4151 {
4152 case '\0':
4153 case '_':
4154 kind = ADA_OBJECT_RENAMING;
4155 break;
4156 case 'E':
4157 kind = ADA_EXCEPTION_RENAMING;
4158 break;
4159 case 'P':
4160 kind = ADA_PACKAGE_RENAMING;
4161 break;
4162 case 'S':
4163 kind = ADA_SUBPROGRAM_RENAMING;
4164 break;
4165 default:
4166 return ADA_NOT_RENAMING;
4167 }
14f9c5c9 4168
aeb5907d
JB
4169 info = TYPE_FIELD_NAME (type, 0);
4170 if (info == NULL)
4171 return ADA_NOT_RENAMING;
4172 if (renamed_entity != NULL)
4173 *renamed_entity = info;
4174 suffix = strstr (info, "___XE");
4175 if (renaming_expr != NULL)
4176 *renaming_expr = suffix + 5;
4177 if (suffix == NULL || suffix == info)
4178 return ADA_NOT_RENAMING;
4179 if (len != NULL)
4180 *len = suffix - info;
4181 return kind;
a5ee536b
JB
4182}
4183
4184/* Compute the value of the given RENAMING_SYM, which is expected to
4185 be a symbol encoding a renaming expression. BLOCK is the block
4186 used to evaluate the renaming. */
52ce6436 4187
a5ee536b
JB
4188static struct value *
4189ada_read_renaming_var_value (struct symbol *renaming_sym,
3977b71f 4190 const struct block *block)
a5ee536b 4191{
bbc13ae3 4192 const char *sym_name;
a5ee536b
JB
4193 struct expression *expr;
4194 struct value *value;
4195 struct cleanup *old_chain = NULL;
4196
bbc13ae3 4197 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
1bb9788d 4198 expr = parse_exp_1 (&sym_name, 0, block, 0);
bbc13ae3 4199 old_chain = make_cleanup (free_current_contents, &expr);
a5ee536b
JB
4200 value = evaluate_expression (expr);
4201
4202 do_cleanups (old_chain);
4203 return value;
4204}
14f9c5c9 4205\f
d2e4a39e 4206
4c4b4cd2 4207 /* Evaluation: Function Calls */
14f9c5c9 4208
4c4b4cd2 4209/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4210 lvalues, and otherwise has the side-effect of allocating memory
4211 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4212
d2e4a39e 4213static struct value *
40bc484c 4214ensure_lval (struct value *val)
14f9c5c9 4215{
40bc484c
JB
4216 if (VALUE_LVAL (val) == not_lval
4217 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4218 {
df407dfe 4219 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4220 const CORE_ADDR addr =
4221 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4222
40bc484c 4223 set_value_address (val, addr);
a84a8a0d 4224 VALUE_LVAL (val) = lval_memory;
40bc484c 4225 write_memory (addr, value_contents (val), len);
c3e5cd34 4226 }
14f9c5c9
AS
4227
4228 return val;
4229}
4230
4231/* Return the value ACTUAL, converted to be an appropriate value for a
4232 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4233 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4234 values not residing in memory, updating it as needed. */
14f9c5c9 4235
a93c0eb6 4236struct value *
40bc484c 4237ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4238{
df407dfe 4239 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4240 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4241 struct type *formal_target =
4242 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4243 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4244 struct type *actual_target =
4245 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4246 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4247
4c4b4cd2 4248 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4249 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4250 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4251 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4252 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4253 {
a84a8a0d 4254 struct value *result;
5b4ee69b 4255
14f9c5c9 4256 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4257 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4258 result = desc_data (actual);
14f9c5c9 4259 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4260 {
4261 if (VALUE_LVAL (actual) != lval_memory)
4262 {
4263 struct value *val;
5b4ee69b 4264
df407dfe 4265 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4266 val = allocate_value (actual_type);
990a07ab 4267 memcpy ((char *) value_contents_raw (val),
0fd88904 4268 (char *) value_contents (actual),
4c4b4cd2 4269 TYPE_LENGTH (actual_type));
40bc484c 4270 actual = ensure_lval (val);
4c4b4cd2 4271 }
a84a8a0d 4272 result = value_addr (actual);
4c4b4cd2 4273 }
a84a8a0d
JB
4274 else
4275 return actual;
b1af9e97 4276 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4277 }
4278 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4279 return ada_value_ind (actual);
4280
4281 return actual;
4282}
4283
438c98a1
JB
4284/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4285 type TYPE. This is usually an inefficient no-op except on some targets
4286 (such as AVR) where the representation of a pointer and an address
4287 differs. */
4288
4289static CORE_ADDR
4290value_pointer (struct value *value, struct type *type)
4291{
4292 struct gdbarch *gdbarch = get_type_arch (type);
4293 unsigned len = TYPE_LENGTH (type);
4294 gdb_byte *buf = alloca (len);
4295 CORE_ADDR addr;
4296
4297 addr = value_address (value);
4298 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4299 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4300 return addr;
4301}
4302
14f9c5c9 4303
4c4b4cd2
PH
4304/* Push a descriptor of type TYPE for array value ARR on the stack at
4305 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4306 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4307 to-descriptor type rather than a descriptor type), a struct value *
4308 representing a pointer to this descriptor. */
14f9c5c9 4309
d2e4a39e 4310static struct value *
40bc484c 4311make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4312{
d2e4a39e
AS
4313 struct type *bounds_type = desc_bounds_type (type);
4314 struct type *desc_type = desc_base_type (type);
4315 struct value *descriptor = allocate_value (desc_type);
4316 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4317 int i;
d2e4a39e 4318
0963b4bd
MS
4319 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4320 i > 0; i -= 1)
14f9c5c9 4321 {
19f220c3
JK
4322 modify_field (value_type (bounds), value_contents_writeable (bounds),
4323 ada_array_bound (arr, i, 0),
4324 desc_bound_bitpos (bounds_type, i, 0),
4325 desc_bound_bitsize (bounds_type, i, 0));
4326 modify_field (value_type (bounds), value_contents_writeable (bounds),
4327 ada_array_bound (arr, i, 1),
4328 desc_bound_bitpos (bounds_type, i, 1),
4329 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4330 }
d2e4a39e 4331
40bc484c 4332 bounds = ensure_lval (bounds);
d2e4a39e 4333
19f220c3
JK
4334 modify_field (value_type (descriptor),
4335 value_contents_writeable (descriptor),
4336 value_pointer (ensure_lval (arr),
4337 TYPE_FIELD_TYPE (desc_type, 0)),
4338 fat_pntr_data_bitpos (desc_type),
4339 fat_pntr_data_bitsize (desc_type));
4340
4341 modify_field (value_type (descriptor),
4342 value_contents_writeable (descriptor),
4343 value_pointer (bounds,
4344 TYPE_FIELD_TYPE (desc_type, 1)),
4345 fat_pntr_bounds_bitpos (desc_type),
4346 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4347
40bc484c 4348 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4349
4350 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4351 return value_addr (descriptor);
4352 else
4353 return descriptor;
4354}
14f9c5c9 4355\f
3d9434b5
JB
4356 /* Symbol Cache Module */
4357
3d9434b5 4358/* Performance measurements made as of 2010-01-15 indicate that
ee01b665 4359 this cache does bring some noticeable improvements. Depending
3d9434b5
JB
4360 on the type of entity being printed, the cache can make it as much
4361 as an order of magnitude faster than without it.
4362
4363 The descriptive type DWARF extension has significantly reduced
4364 the need for this cache, at least when DWARF is being used. However,
4365 even in this case, some expensive name-based symbol searches are still
4366 sometimes necessary - to find an XVZ variable, mostly. */
4367
ee01b665 4368/* Initialize the contents of SYM_CACHE. */
3d9434b5 4369
ee01b665
JB
4370static void
4371ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4372{
4373 obstack_init (&sym_cache->cache_space);
4374 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4375}
3d9434b5 4376
ee01b665
JB
4377/* Free the memory used by SYM_CACHE. */
4378
4379static void
4380ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
3d9434b5 4381{
ee01b665
JB
4382 obstack_free (&sym_cache->cache_space, NULL);
4383 xfree (sym_cache);
4384}
3d9434b5 4385
ee01b665
JB
4386/* Return the symbol cache associated to the given program space PSPACE.
4387 If not allocated for this PSPACE yet, allocate and initialize one. */
3d9434b5 4388
ee01b665
JB
4389static struct ada_symbol_cache *
4390ada_get_symbol_cache (struct program_space *pspace)
4391{
4392 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4393 struct ada_symbol_cache *sym_cache = pspace_data->sym_cache;
4394
4395 if (sym_cache == NULL)
4396 {
4397 sym_cache = XCNEW (struct ada_symbol_cache);
4398 ada_init_symbol_cache (sym_cache);
4399 }
4400
4401 return sym_cache;
4402}
3d9434b5
JB
4403
4404/* Clear all entries from the symbol cache. */
4405
4406static void
4407ada_clear_symbol_cache (void)
4408{
ee01b665
JB
4409 struct ada_symbol_cache *sym_cache
4410 = ada_get_symbol_cache (current_program_space);
4411
4412 obstack_free (&sym_cache->cache_space, NULL);
4413 ada_init_symbol_cache (sym_cache);
3d9434b5
JB
4414}
4415
4416/* Search our cache for an entry matching NAME and NAMESPACE.
4417 Return it if found, or NULL otherwise. */
4418
4419static struct cache_entry **
4420find_entry (const char *name, domain_enum namespace)
4421{
ee01b665
JB
4422 struct ada_symbol_cache *sym_cache
4423 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4424 int h = msymbol_hash (name) % HASH_SIZE;
4425 struct cache_entry **e;
4426
ee01b665 4427 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
3d9434b5
JB
4428 {
4429 if (namespace == (*e)->namespace && strcmp (name, (*e)->name) == 0)
4430 return e;
4431 }
4432 return NULL;
4433}
4434
4435/* Search the symbol cache for an entry matching NAME and NAMESPACE.
4436 Return 1 if found, 0 otherwise.
4437
4438 If an entry was found and SYM is not NULL, set *SYM to the entry's
4439 SYM. Same principle for BLOCK if not NULL. */
96d887e8 4440
96d887e8
PH
4441static int
4442lookup_cached_symbol (const char *name, domain_enum namespace,
f0c5f9b2 4443 struct symbol **sym, const struct block **block)
96d887e8 4444{
3d9434b5
JB
4445 struct cache_entry **e = find_entry (name, namespace);
4446
4447 if (e == NULL)
4448 return 0;
4449 if (sym != NULL)
4450 *sym = (*e)->sym;
4451 if (block != NULL)
4452 *block = (*e)->block;
4453 return 1;
96d887e8
PH
4454}
4455
3d9434b5
JB
4456/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4457 in domain NAMESPACE, save this result in our symbol cache. */
4458
96d887e8
PH
4459static void
4460cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
270140bd 4461 const struct block *block)
96d887e8 4462{
ee01b665
JB
4463 struct ada_symbol_cache *sym_cache
4464 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4465 int h;
4466 char *copy;
4467 struct cache_entry *e;
4468
4469 /* If the symbol is a local symbol, then do not cache it, as a search
4470 for that symbol depends on the context. To determine whether
4471 the symbol is local or not, we check the block where we found it
4472 against the global and static blocks of its associated symtab. */
4473 if (sym
439247b6
DE
4474 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (sym->symtab),
4475 GLOBAL_BLOCK) != block
4476 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (sym->symtab),
4477 STATIC_BLOCK) != block)
3d9434b5
JB
4478 return;
4479
4480 h = msymbol_hash (name) % HASH_SIZE;
ee01b665
JB
4481 e = (struct cache_entry *) obstack_alloc (&sym_cache->cache_space,
4482 sizeof (*e));
4483 e->next = sym_cache->root[h];
4484 sym_cache->root[h] = e;
4485 e->name = copy = obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
3d9434b5
JB
4486 strcpy (copy, name);
4487 e->sym = sym;
4488 e->namespace = namespace;
4489 e->block = block;
96d887e8 4490}
4c4b4cd2
PH
4491\f
4492 /* Symbol Lookup */
4493
c0431670
JB
4494/* Return nonzero if wild matching should be used when searching for
4495 all symbols matching LOOKUP_NAME.
4496
4497 LOOKUP_NAME is expected to be a symbol name after transformation
4498 for Ada lookups (see ada_name_for_lookup). */
4499
4500static int
4501should_use_wild_match (const char *lookup_name)
4502{
4503 return (strstr (lookup_name, "__") == NULL);
4504}
4505
4c4b4cd2
PH
4506/* Return the result of a standard (literal, C-like) lookup of NAME in
4507 given DOMAIN, visible from lexical block BLOCK. */
4508
4509static struct symbol *
4510standard_lookup (const char *name, const struct block *block,
4511 domain_enum domain)
4512{
acbd605d
MGD
4513 /* Initialize it just to avoid a GCC false warning. */
4514 struct symbol *sym = NULL;
4c4b4cd2 4515
2570f2b7 4516 if (lookup_cached_symbol (name, domain, &sym, NULL))
4c4b4cd2 4517 return sym;
2570f2b7
UW
4518 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4519 cache_symbol (name, domain, sym, block_found);
4c4b4cd2
PH
4520 return sym;
4521}
4522
4523
4524/* Non-zero iff there is at least one non-function/non-enumeral symbol
4525 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4526 since they contend in overloading in the same way. */
4527static int
4528is_nonfunction (struct ada_symbol_info syms[], int n)
4529{
4530 int i;
4531
4532 for (i = 0; i < n; i += 1)
4533 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
4534 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
4535 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
14f9c5c9
AS
4536 return 1;
4537
4538 return 0;
4539}
4540
4541/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4542 struct types. Otherwise, they may not. */
14f9c5c9
AS
4543
4544static int
d2e4a39e 4545equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4546{
d2e4a39e 4547 if (type0 == type1)
14f9c5c9 4548 return 1;
d2e4a39e 4549 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4550 || TYPE_CODE (type0) != TYPE_CODE (type1))
4551 return 0;
d2e4a39e 4552 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4553 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4554 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4555 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4556 return 1;
d2e4a39e 4557
14f9c5c9
AS
4558 return 0;
4559}
4560
4561/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4562 no more defined than that of SYM1. */
14f9c5c9
AS
4563
4564static int
d2e4a39e 4565lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4566{
4567 if (sym0 == sym1)
4568 return 1;
176620f1 4569 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4570 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4571 return 0;
4572
d2e4a39e 4573 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4574 {
4575 case LOC_UNDEF:
4576 return 1;
4577 case LOC_TYPEDEF:
4578 {
4c4b4cd2
PH
4579 struct type *type0 = SYMBOL_TYPE (sym0);
4580 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4581 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4582 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4583 int len0 = strlen (name0);
5b4ee69b 4584
4c4b4cd2
PH
4585 return
4586 TYPE_CODE (type0) == TYPE_CODE (type1)
4587 && (equiv_types (type0, type1)
4588 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4589 && strncmp (name1 + len0, "___XV", 5) == 0));
14f9c5c9
AS
4590 }
4591 case LOC_CONST:
4592 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4593 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4594 default:
4595 return 0;
14f9c5c9
AS
4596 }
4597}
4598
4c4b4cd2
PH
4599/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4600 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4601
4602static void
76a01679
JB
4603add_defn_to_vec (struct obstack *obstackp,
4604 struct symbol *sym,
f0c5f9b2 4605 const struct block *block)
14f9c5c9
AS
4606{
4607 int i;
4c4b4cd2 4608 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4609
529cad9c
PH
4610 /* Do not try to complete stub types, as the debugger is probably
4611 already scanning all symbols matching a certain name at the
4612 time when this function is called. Trying to replace the stub
4613 type by its associated full type will cause us to restart a scan
4614 which may lead to an infinite recursion. Instead, the client
4615 collecting the matching symbols will end up collecting several
4616 matches, with at least one of them complete. It can then filter
4617 out the stub ones if needed. */
4618
4c4b4cd2
PH
4619 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4620 {
4621 if (lesseq_defined_than (sym, prevDefns[i].sym))
4622 return;
4623 else if (lesseq_defined_than (prevDefns[i].sym, sym))
4624 {
4625 prevDefns[i].sym = sym;
4626 prevDefns[i].block = block;
4c4b4cd2 4627 return;
76a01679 4628 }
4c4b4cd2
PH
4629 }
4630
4631 {
4632 struct ada_symbol_info info;
4633
4634 info.sym = sym;
4635 info.block = block;
4c4b4cd2
PH
4636 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
4637 }
4638}
4639
4640/* Number of ada_symbol_info structures currently collected in
4641 current vector in *OBSTACKP. */
4642
76a01679
JB
4643static int
4644num_defns_collected (struct obstack *obstackp)
4c4b4cd2
PH
4645{
4646 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
4647}
4648
4649/* Vector of ada_symbol_info structures currently collected in current
4650 vector in *OBSTACKP. If FINISH, close off the vector and return
4651 its final address. */
4652
76a01679 4653static struct ada_symbol_info *
4c4b4cd2
PH
4654defns_collected (struct obstack *obstackp, int finish)
4655{
4656 if (finish)
4657 return obstack_finish (obstackp);
4658 else
4659 return (struct ada_symbol_info *) obstack_base (obstackp);
4660}
4661
7c7b6655
TT
4662/* Return a bound minimal symbol matching NAME according to Ada
4663 decoding rules. Returns an invalid symbol if there is no such
4664 minimal symbol. Names prefixed with "standard__" are handled
4665 specially: "standard__" is first stripped off, and only static and
4666 global symbols are searched. */
4c4b4cd2 4667
7c7b6655 4668struct bound_minimal_symbol
96d887e8 4669ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4670{
7c7b6655 4671 struct bound_minimal_symbol result;
4c4b4cd2 4672 struct objfile *objfile;
96d887e8 4673 struct minimal_symbol *msymbol;
dc4024cd 4674 const int wild_match_p = should_use_wild_match (name);
4c4b4cd2 4675
7c7b6655
TT
4676 memset (&result, 0, sizeof (result));
4677
c0431670
JB
4678 /* Special case: If the user specifies a symbol name inside package
4679 Standard, do a non-wild matching of the symbol name without
4680 the "standard__" prefix. This was primarily introduced in order
4681 to allow the user to specifically access the standard exceptions
4682 using, for instance, Standard.Constraint_Error when Constraint_Error
4683 is ambiguous (due to the user defining its own Constraint_Error
4684 entity inside its program). */
96d887e8 4685 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
c0431670 4686 name += sizeof ("standard__") - 1;
4c4b4cd2 4687
96d887e8
PH
4688 ALL_MSYMBOLS (objfile, msymbol)
4689 {
efd66ac6 4690 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), name, wild_match_p)
96d887e8 4691 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
7c7b6655
TT
4692 {
4693 result.minsym = msymbol;
4694 result.objfile = objfile;
4695 break;
4696 }
96d887e8 4697 }
4c4b4cd2 4698
7c7b6655 4699 return result;
96d887e8 4700}
4c4b4cd2 4701
96d887e8
PH
4702/* For all subprograms that statically enclose the subprogram of the
4703 selected frame, add symbols matching identifier NAME in DOMAIN
4704 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4705 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4706 with a wildcard prefix. */
4c4b4cd2 4707
96d887e8
PH
4708static void
4709add_symbols_from_enclosing_procs (struct obstack *obstackp,
76a01679 4710 const char *name, domain_enum namespace,
48b78332 4711 int wild_match_p)
96d887e8 4712{
96d887e8 4713}
14f9c5c9 4714
96d887e8
PH
4715/* True if TYPE is definitely an artificial type supplied to a symbol
4716 for which no debugging information was given in the symbol file. */
14f9c5c9 4717
96d887e8
PH
4718static int
4719is_nondebugging_type (struct type *type)
4720{
0d5cff50 4721 const char *name = ada_type_name (type);
5b4ee69b 4722
96d887e8
PH
4723 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4724}
4c4b4cd2 4725
8f17729f
JB
4726/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4727 that are deemed "identical" for practical purposes.
4728
4729 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4730 types and that their number of enumerals is identical (in other
4731 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4732
4733static int
4734ada_identical_enum_types_p (struct type *type1, struct type *type2)
4735{
4736 int i;
4737
4738 /* The heuristic we use here is fairly conservative. We consider
4739 that 2 enumerate types are identical if they have the same
4740 number of enumerals and that all enumerals have the same
4741 underlying value and name. */
4742
4743 /* All enums in the type should have an identical underlying value. */
4744 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 4745 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
4746 return 0;
4747
4748 /* All enumerals should also have the same name (modulo any numerical
4749 suffix). */
4750 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4751 {
0d5cff50
DE
4752 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4753 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
4754 int len_1 = strlen (name_1);
4755 int len_2 = strlen (name_2);
4756
4757 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4758 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4759 if (len_1 != len_2
4760 || strncmp (TYPE_FIELD_NAME (type1, i),
4761 TYPE_FIELD_NAME (type2, i),
4762 len_1) != 0)
4763 return 0;
4764 }
4765
4766 return 1;
4767}
4768
4769/* Return nonzero if all the symbols in SYMS are all enumeral symbols
4770 that are deemed "identical" for practical purposes. Sometimes,
4771 enumerals are not strictly identical, but their types are so similar
4772 that they can be considered identical.
4773
4774 For instance, consider the following code:
4775
4776 type Color is (Black, Red, Green, Blue, White);
4777 type RGB_Color is new Color range Red .. Blue;
4778
4779 Type RGB_Color is a subrange of an implicit type which is a copy
4780 of type Color. If we call that implicit type RGB_ColorB ("B" is
4781 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4782 As a result, when an expression references any of the enumeral
4783 by name (Eg. "print green"), the expression is technically
4784 ambiguous and the user should be asked to disambiguate. But
4785 doing so would only hinder the user, since it wouldn't matter
4786 what choice he makes, the outcome would always be the same.
4787 So, for practical purposes, we consider them as the same. */
4788
4789static int
4790symbols_are_identical_enums (struct ada_symbol_info *syms, int nsyms)
4791{
4792 int i;
4793
4794 /* Before performing a thorough comparison check of each type,
4795 we perform a series of inexpensive checks. We expect that these
4796 checks will quickly fail in the vast majority of cases, and thus
4797 help prevent the unnecessary use of a more expensive comparison.
4798 Said comparison also expects us to make some of these checks
4799 (see ada_identical_enum_types_p). */
4800
4801 /* Quick check: All symbols should have an enum type. */
4802 for (i = 0; i < nsyms; i++)
4803 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM)
4804 return 0;
4805
4806 /* Quick check: They should all have the same value. */
4807 for (i = 1; i < nsyms; i++)
4808 if (SYMBOL_VALUE (syms[i].sym) != SYMBOL_VALUE (syms[0].sym))
4809 return 0;
4810
4811 /* Quick check: They should all have the same number of enumerals. */
4812 for (i = 1; i < nsyms; i++)
4813 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].sym))
4814 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].sym)))
4815 return 0;
4816
4817 /* All the sanity checks passed, so we might have a set of
4818 identical enumeration types. Perform a more complete
4819 comparison of the type of each symbol. */
4820 for (i = 1; i < nsyms; i++)
4821 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].sym),
4822 SYMBOL_TYPE (syms[0].sym)))
4823 return 0;
4824
4825 return 1;
4826}
4827
96d887e8
PH
4828/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4829 duplicate other symbols in the list (The only case I know of where
4830 this happens is when object files containing stabs-in-ecoff are
4831 linked with files containing ordinary ecoff debugging symbols (or no
4832 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4833 Returns the number of items in the modified list. */
4c4b4cd2 4834
96d887e8
PH
4835static int
4836remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4837{
4838 int i, j;
4c4b4cd2 4839
8f17729f
JB
4840 /* We should never be called with less than 2 symbols, as there
4841 cannot be any extra symbol in that case. But it's easy to
4842 handle, since we have nothing to do in that case. */
4843 if (nsyms < 2)
4844 return nsyms;
4845
96d887e8
PH
4846 i = 0;
4847 while (i < nsyms)
4848 {
a35ddb44 4849 int remove_p = 0;
339c13b6
JB
4850
4851 /* If two symbols have the same name and one of them is a stub type,
4852 the get rid of the stub. */
4853
4854 if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym))
4855 && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL)
4856 {
4857 for (j = 0; j < nsyms; j++)
4858 {
4859 if (j != i
4860 && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym))
4861 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4862 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4863 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0)
a35ddb44 4864 remove_p = 1;
339c13b6
JB
4865 }
4866 }
4867
4868 /* Two symbols with the same name, same class and same address
4869 should be identical. */
4870
4871 else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
96d887e8
PH
4872 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4873 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4874 {
4875 for (j = 0; j < nsyms; j += 1)
4876 {
4877 if (i != j
4878 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4879 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
76a01679 4880 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
96d887e8
PH
4881 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4882 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4883 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
a35ddb44 4884 remove_p = 1;
4c4b4cd2 4885 }
4c4b4cd2 4886 }
339c13b6 4887
a35ddb44 4888 if (remove_p)
339c13b6
JB
4889 {
4890 for (j = i + 1; j < nsyms; j += 1)
4891 syms[j - 1] = syms[j];
4892 nsyms -= 1;
4893 }
4894
96d887e8 4895 i += 1;
14f9c5c9 4896 }
8f17729f
JB
4897
4898 /* If all the remaining symbols are identical enumerals, then
4899 just keep the first one and discard the rest.
4900
4901 Unlike what we did previously, we do not discard any entry
4902 unless they are ALL identical. This is because the symbol
4903 comparison is not a strict comparison, but rather a practical
4904 comparison. If all symbols are considered identical, then
4905 we can just go ahead and use the first one and discard the rest.
4906 But if we cannot reduce the list to a single element, we have
4907 to ask the user to disambiguate anyways. And if we have to
4908 present a multiple-choice menu, it's less confusing if the list
4909 isn't missing some choices that were identical and yet distinct. */
4910 if (symbols_are_identical_enums (syms, nsyms))
4911 nsyms = 1;
4912
96d887e8 4913 return nsyms;
14f9c5c9
AS
4914}
4915
96d887e8
PH
4916/* Given a type that corresponds to a renaming entity, use the type name
4917 to extract the scope (package name or function name, fully qualified,
4918 and following the GNAT encoding convention) where this renaming has been
4919 defined. The string returned needs to be deallocated after use. */
4c4b4cd2 4920
96d887e8
PH
4921static char *
4922xget_renaming_scope (struct type *renaming_type)
14f9c5c9 4923{
96d887e8 4924 /* The renaming types adhere to the following convention:
0963b4bd 4925 <scope>__<rename>___<XR extension>.
96d887e8
PH
4926 So, to extract the scope, we search for the "___XR" extension,
4927 and then backtrack until we find the first "__". */
76a01679 4928
96d887e8
PH
4929 const char *name = type_name_no_tag (renaming_type);
4930 char *suffix = strstr (name, "___XR");
4931 char *last;
4932 int scope_len;
4933 char *scope;
14f9c5c9 4934
96d887e8
PH
4935 /* Now, backtrack a bit until we find the first "__". Start looking
4936 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 4937
96d887e8
PH
4938 for (last = suffix - 3; last > name; last--)
4939 if (last[0] == '_' && last[1] == '_')
4940 break;
76a01679 4941
96d887e8 4942 /* Make a copy of scope and return it. */
14f9c5c9 4943
96d887e8
PH
4944 scope_len = last - name;
4945 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
14f9c5c9 4946
96d887e8
PH
4947 strncpy (scope, name, scope_len);
4948 scope[scope_len] = '\0';
4c4b4cd2 4949
96d887e8 4950 return scope;
4c4b4cd2
PH
4951}
4952
96d887e8 4953/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 4954
96d887e8
PH
4955static int
4956is_package_name (const char *name)
4c4b4cd2 4957{
96d887e8
PH
4958 /* Here, We take advantage of the fact that no symbols are generated
4959 for packages, while symbols are generated for each function.
4960 So the condition for NAME represent a package becomes equivalent
4961 to NAME not existing in our list of symbols. There is only one
4962 small complication with library-level functions (see below). */
4c4b4cd2 4963
96d887e8 4964 char *fun_name;
76a01679 4965
96d887e8
PH
4966 /* If it is a function that has not been defined at library level,
4967 then we should be able to look it up in the symbols. */
4968 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4969 return 0;
14f9c5c9 4970
96d887e8
PH
4971 /* Library-level function names start with "_ada_". See if function
4972 "_ada_" followed by NAME can be found. */
14f9c5c9 4973
96d887e8 4974 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 4975 functions names cannot contain "__" in them. */
96d887e8
PH
4976 if (strstr (name, "__") != NULL)
4977 return 0;
4c4b4cd2 4978
b435e160 4979 fun_name = xstrprintf ("_ada_%s", name);
14f9c5c9 4980
96d887e8
PH
4981 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4982}
14f9c5c9 4983
96d887e8 4984/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 4985 not visible from FUNCTION_NAME. */
14f9c5c9 4986
96d887e8 4987static int
0d5cff50 4988old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 4989{
aeb5907d 4990 char *scope;
1509e573 4991 struct cleanup *old_chain;
aeb5907d
JB
4992
4993 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4994 return 0;
4995
4996 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
1509e573 4997 old_chain = make_cleanup (xfree, scope);
14f9c5c9 4998
96d887e8
PH
4999 /* If the rename has been defined in a package, then it is visible. */
5000 if (is_package_name (scope))
1509e573
JB
5001 {
5002 do_cleanups (old_chain);
5003 return 0;
5004 }
14f9c5c9 5005
96d887e8
PH
5006 /* Check that the rename is in the current function scope by checking
5007 that its name starts with SCOPE. */
76a01679 5008
96d887e8
PH
5009 /* If the function name starts with "_ada_", it means that it is
5010 a library-level function. Strip this prefix before doing the
5011 comparison, as the encoding for the renaming does not contain
5012 this prefix. */
5013 if (strncmp (function_name, "_ada_", 5) == 0)
5014 function_name += 5;
f26caa11 5015
1509e573
JB
5016 {
5017 int is_invisible = strncmp (function_name, scope, strlen (scope)) != 0;
5018
5019 do_cleanups (old_chain);
5020 return is_invisible;
5021 }
f26caa11
PH
5022}
5023
aeb5907d
JB
5024/* Remove entries from SYMS that corresponds to a renaming entity that
5025 is not visible from the function associated with CURRENT_BLOCK or
5026 that is superfluous due to the presence of more specific renaming
5027 information. Places surviving symbols in the initial entries of
5028 SYMS and returns the number of surviving symbols.
96d887e8
PH
5029
5030 Rationale:
aeb5907d
JB
5031 First, in cases where an object renaming is implemented as a
5032 reference variable, GNAT may produce both the actual reference
5033 variable and the renaming encoding. In this case, we discard the
5034 latter.
5035
5036 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
5037 entity. Unfortunately, STABS currently does not support the definition
5038 of types that are local to a given lexical block, so all renamings types
5039 are emitted at library level. As a consequence, if an application
5040 contains two renaming entities using the same name, and a user tries to
5041 print the value of one of these entities, the result of the ada symbol
5042 lookup will also contain the wrong renaming type.
f26caa11 5043
96d887e8
PH
5044 This function partially covers for this limitation by attempting to
5045 remove from the SYMS list renaming symbols that should be visible
5046 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5047 method with the current information available. The implementation
5048 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5049
5050 - When the user tries to print a rename in a function while there
5051 is another rename entity defined in a package: Normally, the
5052 rename in the function has precedence over the rename in the
5053 package, so the latter should be removed from the list. This is
5054 currently not the case.
5055
5056 - This function will incorrectly remove valid renames if
5057 the CURRENT_BLOCK corresponds to a function which symbol name
5058 has been changed by an "Export" pragma. As a consequence,
5059 the user will be unable to print such rename entities. */
4c4b4cd2 5060
14f9c5c9 5061static int
aeb5907d
JB
5062remove_irrelevant_renamings (struct ada_symbol_info *syms,
5063 int nsyms, const struct block *current_block)
4c4b4cd2
PH
5064{
5065 struct symbol *current_function;
0d5cff50 5066 const char *current_function_name;
4c4b4cd2 5067 int i;
aeb5907d
JB
5068 int is_new_style_renaming;
5069
5070 /* If there is both a renaming foo___XR... encoded as a variable and
5071 a simple variable foo in the same block, discard the latter.
0963b4bd 5072 First, zero out such symbols, then compress. */
aeb5907d
JB
5073 is_new_style_renaming = 0;
5074 for (i = 0; i < nsyms; i += 1)
5075 {
5076 struct symbol *sym = syms[i].sym;
270140bd 5077 const struct block *block = syms[i].block;
aeb5907d
JB
5078 const char *name;
5079 const char *suffix;
5080
5081 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5082 continue;
5083 name = SYMBOL_LINKAGE_NAME (sym);
5084 suffix = strstr (name, "___XR");
5085
5086 if (suffix != NULL)
5087 {
5088 int name_len = suffix - name;
5089 int j;
5b4ee69b 5090
aeb5907d
JB
5091 is_new_style_renaming = 1;
5092 for (j = 0; j < nsyms; j += 1)
5093 if (i != j && syms[j].sym != NULL
5094 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
5095 name_len) == 0
5096 && block == syms[j].block)
5097 syms[j].sym = NULL;
5098 }
5099 }
5100 if (is_new_style_renaming)
5101 {
5102 int j, k;
5103
5104 for (j = k = 0; j < nsyms; j += 1)
5105 if (syms[j].sym != NULL)
5106 {
5107 syms[k] = syms[j];
5108 k += 1;
5109 }
5110 return k;
5111 }
4c4b4cd2
PH
5112
5113 /* Extract the function name associated to CURRENT_BLOCK.
5114 Abort if unable to do so. */
76a01679 5115
4c4b4cd2
PH
5116 if (current_block == NULL)
5117 return nsyms;
76a01679 5118
7f0df278 5119 current_function = block_linkage_function (current_block);
4c4b4cd2
PH
5120 if (current_function == NULL)
5121 return nsyms;
5122
5123 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5124 if (current_function_name == NULL)
5125 return nsyms;
5126
5127 /* Check each of the symbols, and remove it from the list if it is
5128 a type corresponding to a renaming that is out of the scope of
5129 the current block. */
5130
5131 i = 0;
5132 while (i < nsyms)
5133 {
aeb5907d
JB
5134 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
5135 == ADA_OBJECT_RENAMING
5136 && old_renaming_is_invisible (syms[i].sym, current_function_name))
4c4b4cd2
PH
5137 {
5138 int j;
5b4ee69b 5139
aeb5907d 5140 for (j = i + 1; j < nsyms; j += 1)
76a01679 5141 syms[j - 1] = syms[j];
4c4b4cd2
PH
5142 nsyms -= 1;
5143 }
5144 else
5145 i += 1;
5146 }
5147
5148 return nsyms;
5149}
5150
339c13b6
JB
5151/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5152 whose name and domain match NAME and DOMAIN respectively.
5153 If no match was found, then extend the search to "enclosing"
5154 routines (in other words, if we're inside a nested function,
5155 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
5156 If WILD_MATCH_P is nonzero, perform the naming matching in
5157 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
5158
5159 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5160
5161static void
5162ada_add_local_symbols (struct obstack *obstackp, const char *name,
f0c5f9b2 5163 const struct block *block, domain_enum domain,
d0a8ab18 5164 int wild_match_p)
339c13b6
JB
5165{
5166 int block_depth = 0;
5167
5168 while (block != NULL)
5169 {
5170 block_depth += 1;
d0a8ab18
JB
5171 ada_add_block_symbols (obstackp, block, name, domain, NULL,
5172 wild_match_p);
339c13b6
JB
5173
5174 /* If we found a non-function match, assume that's the one. */
5175 if (is_nonfunction (defns_collected (obstackp, 0),
5176 num_defns_collected (obstackp)))
5177 return;
5178
5179 block = BLOCK_SUPERBLOCK (block);
5180 }
5181
5182 /* If no luck so far, try to find NAME as a local symbol in some lexically
5183 enclosing subprogram. */
5184 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
d0a8ab18 5185 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match_p);
339c13b6
JB
5186}
5187
ccefe4c4 5188/* An object of this type is used as the user_data argument when
40658b94 5189 calling the map_matching_symbols method. */
ccefe4c4 5190
40658b94 5191struct match_data
ccefe4c4 5192{
40658b94 5193 struct objfile *objfile;
ccefe4c4 5194 struct obstack *obstackp;
40658b94
PH
5195 struct symbol *arg_sym;
5196 int found_sym;
ccefe4c4
TT
5197};
5198
40658b94
PH
5199/* A callback for add_matching_symbols that adds SYM, found in BLOCK,
5200 to a list of symbols. DATA0 is a pointer to a struct match_data *
5201 containing the obstack that collects the symbol list, the file that SYM
5202 must come from, a flag indicating whether a non-argument symbol has
5203 been found in the current block, and the last argument symbol
5204 passed in SYM within the current block (if any). When SYM is null,
5205 marking the end of a block, the argument symbol is added if no
5206 other has been found. */
ccefe4c4 5207
40658b94
PH
5208static int
5209aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 5210{
40658b94
PH
5211 struct match_data *data = (struct match_data *) data0;
5212
5213 if (sym == NULL)
5214 {
5215 if (!data->found_sym && data->arg_sym != NULL)
5216 add_defn_to_vec (data->obstackp,
5217 fixup_symbol_section (data->arg_sym, data->objfile),
5218 block);
5219 data->found_sym = 0;
5220 data->arg_sym = NULL;
5221 }
5222 else
5223 {
5224 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5225 return 0;
5226 else if (SYMBOL_IS_ARGUMENT (sym))
5227 data->arg_sym = sym;
5228 else
5229 {
5230 data->found_sym = 1;
5231 add_defn_to_vec (data->obstackp,
5232 fixup_symbol_section (sym, data->objfile),
5233 block);
5234 }
5235 }
5236 return 0;
5237}
5238
db230ce3
JB
5239/* Implements compare_names, but only applying the comparision using
5240 the given CASING. */
5b4ee69b 5241
40658b94 5242static int
db230ce3
JB
5243compare_names_with_case (const char *string1, const char *string2,
5244 enum case_sensitivity casing)
40658b94
PH
5245{
5246 while (*string1 != '\0' && *string2 != '\0')
5247 {
db230ce3
JB
5248 char c1, c2;
5249
40658b94
PH
5250 if (isspace (*string1) || isspace (*string2))
5251 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
5252
5253 if (casing == case_sensitive_off)
5254 {
5255 c1 = tolower (*string1);
5256 c2 = tolower (*string2);
5257 }
5258 else
5259 {
5260 c1 = *string1;
5261 c2 = *string2;
5262 }
5263 if (c1 != c2)
40658b94 5264 break;
db230ce3 5265
40658b94
PH
5266 string1 += 1;
5267 string2 += 1;
5268 }
db230ce3 5269
40658b94
PH
5270 switch (*string1)
5271 {
5272 case '(':
5273 return strcmp_iw_ordered (string1, string2);
5274 case '_':
5275 if (*string2 == '\0')
5276 {
052874e8 5277 if (is_name_suffix (string1))
40658b94
PH
5278 return 0;
5279 else
1a1d5513 5280 return 1;
40658b94 5281 }
dbb8534f 5282 /* FALLTHROUGH */
40658b94
PH
5283 default:
5284 if (*string2 == '(')
5285 return strcmp_iw_ordered (string1, string2);
5286 else
db230ce3
JB
5287 {
5288 if (casing == case_sensitive_off)
5289 return tolower (*string1) - tolower (*string2);
5290 else
5291 return *string1 - *string2;
5292 }
40658b94 5293 }
ccefe4c4
TT
5294}
5295
db230ce3
JB
5296/* Compare STRING1 to STRING2, with results as for strcmp.
5297 Compatible with strcmp_iw_ordered in that...
5298
5299 strcmp_iw_ordered (STRING1, STRING2) <= 0
5300
5301 ... implies...
5302
5303 compare_names (STRING1, STRING2) <= 0
5304
5305 (they may differ as to what symbols compare equal). */
5306
5307static int
5308compare_names (const char *string1, const char *string2)
5309{
5310 int result;
5311
5312 /* Similar to what strcmp_iw_ordered does, we need to perform
5313 a case-insensitive comparison first, and only resort to
5314 a second, case-sensitive, comparison if the first one was
5315 not sufficient to differentiate the two strings. */
5316
5317 result = compare_names_with_case (string1, string2, case_sensitive_off);
5318 if (result == 0)
5319 result = compare_names_with_case (string1, string2, case_sensitive_on);
5320
5321 return result;
5322}
5323
339c13b6
JB
5324/* Add to OBSTACKP all non-local symbols whose name and domain match
5325 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
5326 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
5327
5328static void
40658b94
PH
5329add_nonlocal_symbols (struct obstack *obstackp, const char *name,
5330 domain_enum domain, int global,
5331 int is_wild_match)
339c13b6
JB
5332{
5333 struct objfile *objfile;
40658b94 5334 struct match_data data;
339c13b6 5335
6475f2fe 5336 memset (&data, 0, sizeof data);
ccefe4c4 5337 data.obstackp = obstackp;
339c13b6 5338
ccefe4c4 5339 ALL_OBJFILES (objfile)
40658b94
PH
5340 {
5341 data.objfile = objfile;
5342
5343 if (is_wild_match)
4186eb54
KS
5344 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5345 aux_add_nonlocal_symbols, &data,
5346 wild_match, NULL);
40658b94 5347 else
4186eb54
KS
5348 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5349 aux_add_nonlocal_symbols, &data,
5350 full_match, compare_names);
40658b94
PH
5351 }
5352
5353 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5354 {
5355 ALL_OBJFILES (objfile)
5356 {
5357 char *name1 = alloca (strlen (name) + sizeof ("_ada_"));
5358 strcpy (name1, "_ada_");
5359 strcpy (name1 + sizeof ("_ada_") - 1, name);
5360 data.objfile = objfile;
ade7ed9e
DE
5361 objfile->sf->qf->map_matching_symbols (objfile, name1, domain,
5362 global,
0963b4bd
MS
5363 aux_add_nonlocal_symbols,
5364 &data,
40658b94
PH
5365 full_match, compare_names);
5366 }
5367 }
339c13b6
JB
5368}
5369
4eeaa230
DE
5370/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and, if full_search is
5371 non-zero, enclosing scope and in global scopes, returning the number of
5372 matches.
9f88c959 5373 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4c4b4cd2 5374 indicating the symbols found and the blocks and symbol tables (if
4eeaa230
DE
5375 any) in which they were found. This vector is transient---good only to
5376 the next call of ada_lookup_symbol_list.
5377
5378 When full_search is non-zero, any non-function/non-enumeral
4c4b4cd2
PH
5379 symbol match within the nest of blocks whose innermost member is BLOCK0,
5380 is the one match returned (no other matches in that or
d9680e73 5381 enclosing blocks is returned). If there are any matches in or
4eeaa230
DE
5382 surrounding BLOCK0, then these alone are returned.
5383
9f88c959 5384 Names prefixed with "standard__" are handled specially: "standard__"
4c4b4cd2 5385 is first stripped off, and only static and global symbols are searched. */
14f9c5c9 5386
4eeaa230
DE
5387static int
5388ada_lookup_symbol_list_worker (const char *name0, const struct block *block0,
5389 domain_enum namespace,
5390 struct ada_symbol_info **results,
5391 int full_search)
14f9c5c9
AS
5392{
5393 struct symbol *sym;
f0c5f9b2 5394 const struct block *block;
4c4b4cd2 5395 const char *name;
82ccd55e 5396 const int wild_match_p = should_use_wild_match (name0);
14f9c5c9 5397 int cacheIfUnique;
4c4b4cd2 5398 int ndefns;
14f9c5c9 5399
4c4b4cd2
PH
5400 obstack_free (&symbol_list_obstack, NULL);
5401 obstack_init (&symbol_list_obstack);
14f9c5c9 5402
14f9c5c9
AS
5403 cacheIfUnique = 0;
5404
5405 /* Search specified block and its superiors. */
5406
4c4b4cd2 5407 name = name0;
f0c5f9b2 5408 block = block0;
339c13b6
JB
5409
5410 /* Special case: If the user specifies a symbol name inside package
5411 Standard, do a non-wild matching of the symbol name without
5412 the "standard__" prefix. This was primarily introduced in order
5413 to allow the user to specifically access the standard exceptions
5414 using, for instance, Standard.Constraint_Error when Constraint_Error
5415 is ambiguous (due to the user defining its own Constraint_Error
5416 entity inside its program). */
4c4b4cd2
PH
5417 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
5418 {
4c4b4cd2
PH
5419 block = NULL;
5420 name = name0 + sizeof ("standard__") - 1;
5421 }
5422
339c13b6 5423 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5424
4eeaa230
DE
5425 if (block != NULL)
5426 {
5427 if (full_search)
5428 {
5429 ada_add_local_symbols (&symbol_list_obstack, name, block,
5430 namespace, wild_match_p);
5431 }
5432 else
5433 {
5434 /* In the !full_search case we're are being called by
5435 ada_iterate_over_symbols, and we don't want to search
5436 superblocks. */
5437 ada_add_block_symbols (&symbol_list_obstack, block, name,
5438 namespace, NULL, wild_match_p);
5439 }
5440 if (num_defns_collected (&symbol_list_obstack) > 0 || !full_search)
5441 goto done;
5442 }
d2e4a39e 5443
339c13b6
JB
5444 /* No non-global symbols found. Check our cache to see if we have
5445 already performed this search before. If we have, then return
5446 the same result. */
5447
14f9c5c9 5448 cacheIfUnique = 1;
2570f2b7 5449 if (lookup_cached_symbol (name0, namespace, &sym, &block))
4c4b4cd2
PH
5450 {
5451 if (sym != NULL)
2570f2b7 5452 add_defn_to_vec (&symbol_list_obstack, sym, block);
4c4b4cd2
PH
5453 goto done;
5454 }
14f9c5c9 5455
339c13b6
JB
5456 /* Search symbols from all global blocks. */
5457
40658b94 5458 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 1,
82ccd55e 5459 wild_match_p);
d2e4a39e 5460
4c4b4cd2 5461 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5462 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5463
4c4b4cd2 5464 if (num_defns_collected (&symbol_list_obstack) == 0)
40658b94 5465 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 0,
82ccd55e 5466 wild_match_p);
14f9c5c9 5467
4c4b4cd2
PH
5468done:
5469 ndefns = num_defns_collected (&symbol_list_obstack);
5470 *results = defns_collected (&symbol_list_obstack, 1);
5471
5472 ndefns = remove_extra_symbols (*results, ndefns);
5473
2ad01556 5474 if (ndefns == 0 && full_search)
2570f2b7 5475 cache_symbol (name0, namespace, NULL, NULL);
14f9c5c9 5476
2ad01556 5477 if (ndefns == 1 && full_search && cacheIfUnique)
2570f2b7 5478 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
14f9c5c9 5479
aeb5907d 5480 ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
14f9c5c9 5481
14f9c5c9
AS
5482 return ndefns;
5483}
5484
4eeaa230
DE
5485/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and
5486 in global scopes, returning the number of matches, and setting *RESULTS
5487 to a vector of (SYM,BLOCK) tuples.
5488 See ada_lookup_symbol_list_worker for further details. */
5489
5490int
5491ada_lookup_symbol_list (const char *name0, const struct block *block0,
5492 domain_enum domain, struct ada_symbol_info **results)
5493{
5494 return ada_lookup_symbol_list_worker (name0, block0, domain, results, 1);
5495}
5496
5497/* Implementation of the la_iterate_over_symbols method. */
5498
5499static void
5500ada_iterate_over_symbols (const struct block *block,
5501 const char *name, domain_enum domain,
5502 symbol_found_callback_ftype *callback,
5503 void *data)
5504{
5505 int ndefs, i;
5506 struct ada_symbol_info *results;
5507
5508 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5509 for (i = 0; i < ndefs; ++i)
5510 {
5511 if (! (*callback) (results[i].sym, data))
5512 break;
5513 }
5514}
5515
f8eba3c6
TT
5516/* If NAME is the name of an entity, return a string that should
5517 be used to look that entity up in Ada units. This string should
5518 be deallocated after use using xfree.
5519
5520 NAME can have any form that the "break" or "print" commands might
5521 recognize. In other words, it does not have to be the "natural"
5522 name, or the "encoded" name. */
5523
5524char *
5525ada_name_for_lookup (const char *name)
5526{
5527 char *canon;
5528 int nlen = strlen (name);
5529
5530 if (name[0] == '<' && name[nlen - 1] == '>')
5531 {
5532 canon = xmalloc (nlen - 1);
5533 memcpy (canon, name + 1, nlen - 2);
5534 canon[nlen - 2] = '\0';
5535 }
5536 else
5537 canon = xstrdup (ada_encode (ada_fold_name (name)));
5538 return canon;
5539}
5540
4e5c77fe
JB
5541/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5542 to 1, but choosing the first symbol found if there are multiple
5543 choices.
5544
5e2336be
JB
5545 The result is stored in *INFO, which must be non-NULL.
5546 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5547
5548void
5549ada_lookup_encoded_symbol (const char *name, const struct block *block,
5550 domain_enum namespace,
5e2336be 5551 struct ada_symbol_info *info)
14f9c5c9 5552{
4c4b4cd2 5553 struct ada_symbol_info *candidates;
14f9c5c9
AS
5554 int n_candidates;
5555
5e2336be
JB
5556 gdb_assert (info != NULL);
5557 memset (info, 0, sizeof (struct ada_symbol_info));
4e5c77fe 5558
4eeaa230 5559 n_candidates = ada_lookup_symbol_list (name, block, namespace, &candidates);
14f9c5c9 5560 if (n_candidates == 0)
4e5c77fe 5561 return;
4c4b4cd2 5562
5e2336be
JB
5563 *info = candidates[0];
5564 info->sym = fixup_symbol_section (info->sym, NULL);
4e5c77fe 5565}
aeb5907d
JB
5566
5567/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5568 scope and in global scopes, or NULL if none. NAME is folded and
5569 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5570 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5571 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5572
aeb5907d
JB
5573struct symbol *
5574ada_lookup_symbol (const char *name, const struct block *block0,
21b556f4 5575 domain_enum namespace, int *is_a_field_of_this)
aeb5907d 5576{
5e2336be 5577 struct ada_symbol_info info;
4e5c77fe 5578
aeb5907d
JB
5579 if (is_a_field_of_this != NULL)
5580 *is_a_field_of_this = 0;
5581
4e5c77fe 5582 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
5e2336be
JB
5583 block0, namespace, &info);
5584 return info.sym;
4c4b4cd2 5585}
14f9c5c9 5586
4c4b4cd2
PH
5587static struct symbol *
5588ada_lookup_symbol_nonlocal (const char *name,
76a01679 5589 const struct block *block,
21b556f4 5590 const domain_enum domain)
4c4b4cd2 5591{
94af9270 5592 return ada_lookup_symbol (name, block_static_block (block), domain, NULL);
14f9c5c9
AS
5593}
5594
5595
4c4b4cd2
PH
5596/* True iff STR is a possible encoded suffix of a normal Ada name
5597 that is to be ignored for matching purposes. Suffixes of parallel
5598 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5599 are given by any of the regular expressions:
4c4b4cd2 5600
babe1480
JB
5601 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5602 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5603 TKB [subprogram suffix for task bodies]
babe1480 5604 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5605 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5606
5607 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5608 match is performed. This sequence is used to differentiate homonyms,
5609 is an optional part of a valid name suffix. */
4c4b4cd2 5610
14f9c5c9 5611static int
d2e4a39e 5612is_name_suffix (const char *str)
14f9c5c9
AS
5613{
5614 int k;
4c4b4cd2
PH
5615 const char *matching;
5616 const int len = strlen (str);
5617
babe1480
JB
5618 /* Skip optional leading __[0-9]+. */
5619
4c4b4cd2
PH
5620 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5621 {
babe1480
JB
5622 str += 3;
5623 while (isdigit (str[0]))
5624 str += 1;
4c4b4cd2 5625 }
babe1480
JB
5626
5627 /* [.$][0-9]+ */
4c4b4cd2 5628
babe1480 5629 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5630 {
babe1480 5631 matching = str + 1;
4c4b4cd2
PH
5632 while (isdigit (matching[0]))
5633 matching += 1;
5634 if (matching[0] == '\0')
5635 return 1;
5636 }
5637
5638 /* ___[0-9]+ */
babe1480 5639
4c4b4cd2
PH
5640 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5641 {
5642 matching = str + 3;
5643 while (isdigit (matching[0]))
5644 matching += 1;
5645 if (matching[0] == '\0')
5646 return 1;
5647 }
5648
9ac7f98e
JB
5649 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5650
5651 if (strcmp (str, "TKB") == 0)
5652 return 1;
5653
529cad9c
PH
5654#if 0
5655 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
5656 with a N at the end. Unfortunately, the compiler uses the same
5657 convention for other internal types it creates. So treating
529cad9c 5658 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
5659 some regressions. For instance, consider the case of an enumerated
5660 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
5661 name ends with N.
5662 Having a single character like this as a suffix carrying some
0963b4bd 5663 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
5664 to be something like "_N" instead. In the meantime, do not do
5665 the following check. */
5666 /* Protected Object Subprograms */
5667 if (len == 1 && str [0] == 'N')
5668 return 1;
5669#endif
5670
5671 /* _E[0-9]+[bs]$ */
5672 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5673 {
5674 matching = str + 3;
5675 while (isdigit (matching[0]))
5676 matching += 1;
5677 if ((matching[0] == 'b' || matching[0] == 's')
5678 && matching [1] == '\0')
5679 return 1;
5680 }
5681
4c4b4cd2
PH
5682 /* ??? We should not modify STR directly, as we are doing below. This
5683 is fine in this case, but may become problematic later if we find
5684 that this alternative did not work, and want to try matching
5685 another one from the begining of STR. Since we modified it, we
5686 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
5687 if (str[0] == 'X')
5688 {
5689 str += 1;
d2e4a39e 5690 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
5691 {
5692 if (str[0] != 'n' && str[0] != 'b')
5693 return 0;
5694 str += 1;
5695 }
14f9c5c9 5696 }
babe1480 5697
14f9c5c9
AS
5698 if (str[0] == '\000')
5699 return 1;
babe1480 5700
d2e4a39e 5701 if (str[0] == '_')
14f9c5c9
AS
5702 {
5703 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 5704 return 0;
d2e4a39e 5705 if (str[2] == '_')
4c4b4cd2 5706 {
61ee279c
PH
5707 if (strcmp (str + 3, "JM") == 0)
5708 return 1;
5709 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5710 the LJM suffix in favor of the JM one. But we will
5711 still accept LJM as a valid suffix for a reasonable
5712 amount of time, just to allow ourselves to debug programs
5713 compiled using an older version of GNAT. */
4c4b4cd2
PH
5714 if (strcmp (str + 3, "LJM") == 0)
5715 return 1;
5716 if (str[3] != 'X')
5717 return 0;
1265e4aa
JB
5718 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5719 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
5720 return 1;
5721 if (str[4] == 'R' && str[5] != 'T')
5722 return 1;
5723 return 0;
5724 }
5725 if (!isdigit (str[2]))
5726 return 0;
5727 for (k = 3; str[k] != '\0'; k += 1)
5728 if (!isdigit (str[k]) && str[k] != '_')
5729 return 0;
14f9c5c9
AS
5730 return 1;
5731 }
4c4b4cd2 5732 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 5733 {
4c4b4cd2
PH
5734 for (k = 2; str[k] != '\0'; k += 1)
5735 if (!isdigit (str[k]) && str[k] != '_')
5736 return 0;
14f9c5c9
AS
5737 return 1;
5738 }
5739 return 0;
5740}
d2e4a39e 5741
aeb5907d
JB
5742/* Return non-zero if the string starting at NAME and ending before
5743 NAME_END contains no capital letters. */
529cad9c
PH
5744
5745static int
5746is_valid_name_for_wild_match (const char *name0)
5747{
5748 const char *decoded_name = ada_decode (name0);
5749 int i;
5750
5823c3ef
JB
5751 /* If the decoded name starts with an angle bracket, it means that
5752 NAME0 does not follow the GNAT encoding format. It should then
5753 not be allowed as a possible wild match. */
5754 if (decoded_name[0] == '<')
5755 return 0;
5756
529cad9c
PH
5757 for (i=0; decoded_name[i] != '\0'; i++)
5758 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5759 return 0;
5760
5761 return 1;
5762}
5763
73589123
PH
5764/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5765 that could start a simple name. Assumes that *NAMEP points into
5766 the string beginning at NAME0. */
4c4b4cd2 5767
14f9c5c9 5768static int
73589123 5769advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 5770{
73589123 5771 const char *name = *namep;
5b4ee69b 5772
5823c3ef 5773 while (1)
14f9c5c9 5774 {
aa27d0b3 5775 int t0, t1;
73589123
PH
5776
5777 t0 = *name;
5778 if (t0 == '_')
5779 {
5780 t1 = name[1];
5781 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5782 {
5783 name += 1;
5784 if (name == name0 + 5 && strncmp (name0, "_ada", 4) == 0)
5785 break;
5786 else
5787 name += 1;
5788 }
aa27d0b3
JB
5789 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5790 || name[2] == target0))
73589123
PH
5791 {
5792 name += 2;
5793 break;
5794 }
5795 else
5796 return 0;
5797 }
5798 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5799 name += 1;
5800 else
5823c3ef 5801 return 0;
73589123
PH
5802 }
5803
5804 *namep = name;
5805 return 1;
5806}
5807
5808/* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5809 informational suffixes of NAME (i.e., for which is_name_suffix is
5810 true). Assumes that PATN is a lower-cased Ada simple name. */
5811
5812static int
5813wild_match (const char *name, const char *patn)
5814{
22e048c9 5815 const char *p;
73589123
PH
5816 const char *name0 = name;
5817
5818 while (1)
5819 {
5820 const char *match = name;
5821
5822 if (*name == *patn)
5823 {
5824 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5825 if (*p != *name)
5826 break;
5827 if (*p == '\0' && is_name_suffix (name))
5828 return match != name0 && !is_valid_name_for_wild_match (name0);
5829
5830 if (name[-1] == '_')
5831 name -= 1;
5832 }
5833 if (!advance_wild_match (&name, name0, *patn))
5834 return 1;
96d887e8 5835 }
96d887e8
PH
5836}
5837
40658b94
PH
5838/* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
5839 informational suffix. */
5840
c4d840bd
PH
5841static int
5842full_match (const char *sym_name, const char *search_name)
5843{
40658b94 5844 return !match_name (sym_name, search_name, 0);
c4d840bd
PH
5845}
5846
5847
96d887e8
PH
5848/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5849 vector *defn_symbols, updating the list of symbols in OBSTACKP
0963b4bd 5850 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4eeaa230 5851 OBJFILE is the section containing BLOCK. */
96d887e8
PH
5852
5853static void
5854ada_add_block_symbols (struct obstack *obstackp,
f0c5f9b2 5855 const struct block *block, const char *name,
96d887e8 5856 domain_enum domain, struct objfile *objfile,
2570f2b7 5857 int wild)
96d887e8 5858{
8157b174 5859 struct block_iterator iter;
96d887e8
PH
5860 int name_len = strlen (name);
5861 /* A matching argument symbol, if any. */
5862 struct symbol *arg_sym;
5863 /* Set true when we find a matching non-argument symbol. */
5864 int found_sym;
5865 struct symbol *sym;
5866
5867 arg_sym = NULL;
5868 found_sym = 0;
5869 if (wild)
5870 {
8157b174
TT
5871 for (sym = block_iter_match_first (block, name, wild_match, &iter);
5872 sym != NULL; sym = block_iter_match_next (name, wild_match, &iter))
76a01679 5873 {
4186eb54
KS
5874 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5875 SYMBOL_DOMAIN (sym), domain)
73589123 5876 && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0)
76a01679 5877 {
2a2d4dc3
AS
5878 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5879 continue;
5880 else if (SYMBOL_IS_ARGUMENT (sym))
5881 arg_sym = sym;
5882 else
5883 {
76a01679
JB
5884 found_sym = 1;
5885 add_defn_to_vec (obstackp,
5886 fixup_symbol_section (sym, objfile),
2570f2b7 5887 block);
76a01679
JB
5888 }
5889 }
5890 }
96d887e8
PH
5891 }
5892 else
5893 {
8157b174
TT
5894 for (sym = block_iter_match_first (block, name, full_match, &iter);
5895 sym != NULL; sym = block_iter_match_next (name, full_match, &iter))
76a01679 5896 {
4186eb54
KS
5897 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5898 SYMBOL_DOMAIN (sym), domain))
76a01679 5899 {
c4d840bd
PH
5900 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5901 {
5902 if (SYMBOL_IS_ARGUMENT (sym))
5903 arg_sym = sym;
5904 else
2a2d4dc3 5905 {
c4d840bd
PH
5906 found_sym = 1;
5907 add_defn_to_vec (obstackp,
5908 fixup_symbol_section (sym, objfile),
5909 block);
2a2d4dc3 5910 }
c4d840bd 5911 }
76a01679
JB
5912 }
5913 }
96d887e8
PH
5914 }
5915
5916 if (!found_sym && arg_sym != NULL)
5917 {
76a01679
JB
5918 add_defn_to_vec (obstackp,
5919 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5920 block);
96d887e8
PH
5921 }
5922
5923 if (!wild)
5924 {
5925 arg_sym = NULL;
5926 found_sym = 0;
5927
5928 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 5929 {
4186eb54
KS
5930 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5931 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
5932 {
5933 int cmp;
5934
5935 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5936 if (cmp == 0)
5937 {
5938 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5939 if (cmp == 0)
5940 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5941 name_len);
5942 }
5943
5944 if (cmp == 0
5945 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5946 {
2a2d4dc3
AS
5947 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5948 {
5949 if (SYMBOL_IS_ARGUMENT (sym))
5950 arg_sym = sym;
5951 else
5952 {
5953 found_sym = 1;
5954 add_defn_to_vec (obstackp,
5955 fixup_symbol_section (sym, objfile),
5956 block);
5957 }
5958 }
76a01679
JB
5959 }
5960 }
76a01679 5961 }
96d887e8
PH
5962
5963 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5964 They aren't parameters, right? */
5965 if (!found_sym && arg_sym != NULL)
5966 {
5967 add_defn_to_vec (obstackp,
76a01679 5968 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5969 block);
96d887e8
PH
5970 }
5971 }
5972}
5973\f
41d27058
JB
5974
5975 /* Symbol Completion */
5976
5977/* If SYM_NAME is a completion candidate for TEXT, return this symbol
5978 name in a form that's appropriate for the completion. The result
5979 does not need to be deallocated, but is only good until the next call.
5980
5981 TEXT_LEN is equal to the length of TEXT.
e701b3c0 5982 Perform a wild match if WILD_MATCH_P is set.
6ea35997 5983 ENCODED_P should be set if TEXT represents the start of a symbol name
41d27058
JB
5984 in its encoded form. */
5985
5986static const char *
5987symbol_completion_match (const char *sym_name,
5988 const char *text, int text_len,
6ea35997 5989 int wild_match_p, int encoded_p)
41d27058 5990{
41d27058
JB
5991 const int verbatim_match = (text[0] == '<');
5992 int match = 0;
5993
5994 if (verbatim_match)
5995 {
5996 /* Strip the leading angle bracket. */
5997 text = text + 1;
5998 text_len--;
5999 }
6000
6001 /* First, test against the fully qualified name of the symbol. */
6002
6003 if (strncmp (sym_name, text, text_len) == 0)
6004 match = 1;
6005
6ea35997 6006 if (match && !encoded_p)
41d27058
JB
6007 {
6008 /* One needed check before declaring a positive match is to verify
6009 that iff we are doing a verbatim match, the decoded version
6010 of the symbol name starts with '<'. Otherwise, this symbol name
6011 is not a suitable completion. */
6012 const char *sym_name_copy = sym_name;
6013 int has_angle_bracket;
6014
6015 sym_name = ada_decode (sym_name);
6016 has_angle_bracket = (sym_name[0] == '<');
6017 match = (has_angle_bracket == verbatim_match);
6018 sym_name = sym_name_copy;
6019 }
6020
6021 if (match && !verbatim_match)
6022 {
6023 /* When doing non-verbatim match, another check that needs to
6024 be done is to verify that the potentially matching symbol name
6025 does not include capital letters, because the ada-mode would
6026 not be able to understand these symbol names without the
6027 angle bracket notation. */
6028 const char *tmp;
6029
6030 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6031 if (*tmp != '\0')
6032 match = 0;
6033 }
6034
6035 /* Second: Try wild matching... */
6036
e701b3c0 6037 if (!match && wild_match_p)
41d27058
JB
6038 {
6039 /* Since we are doing wild matching, this means that TEXT
6040 may represent an unqualified symbol name. We therefore must
6041 also compare TEXT against the unqualified name of the symbol. */
6042 sym_name = ada_unqualified_name (ada_decode (sym_name));
6043
6044 if (strncmp (sym_name, text, text_len) == 0)
6045 match = 1;
6046 }
6047
6048 /* Finally: If we found a mach, prepare the result to return. */
6049
6050 if (!match)
6051 return NULL;
6052
6053 if (verbatim_match)
6054 sym_name = add_angle_brackets (sym_name);
6055
6ea35997 6056 if (!encoded_p)
41d27058
JB
6057 sym_name = ada_decode (sym_name);
6058
6059 return sym_name;
6060}
6061
6062/* A companion function to ada_make_symbol_completion_list().
6063 Check if SYM_NAME represents a symbol which name would be suitable
6064 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
6065 it is appended at the end of the given string vector SV.
6066
6067 ORIG_TEXT is the string original string from the user command
6068 that needs to be completed. WORD is the entire command on which
6069 completion should be performed. These two parameters are used to
6070 determine which part of the symbol name should be added to the
6071 completion vector.
c0af1706 6072 if WILD_MATCH_P is set, then wild matching is performed.
cb8e9b97 6073 ENCODED_P should be set if TEXT represents a symbol name in its
41d27058
JB
6074 encoded formed (in which case the completion should also be
6075 encoded). */
6076
6077static void
d6565258 6078symbol_completion_add (VEC(char_ptr) **sv,
41d27058
JB
6079 const char *sym_name,
6080 const char *text, int text_len,
6081 const char *orig_text, const char *word,
cb8e9b97 6082 int wild_match_p, int encoded_p)
41d27058
JB
6083{
6084 const char *match = symbol_completion_match (sym_name, text, text_len,
cb8e9b97 6085 wild_match_p, encoded_p);
41d27058
JB
6086 char *completion;
6087
6088 if (match == NULL)
6089 return;
6090
6091 /* We found a match, so add the appropriate completion to the given
6092 string vector. */
6093
6094 if (word == orig_text)
6095 {
6096 completion = xmalloc (strlen (match) + 5);
6097 strcpy (completion, match);
6098 }
6099 else if (word > orig_text)
6100 {
6101 /* Return some portion of sym_name. */
6102 completion = xmalloc (strlen (match) + 5);
6103 strcpy (completion, match + (word - orig_text));
6104 }
6105 else
6106 {
6107 /* Return some of ORIG_TEXT plus sym_name. */
6108 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
6109 strncpy (completion, word, orig_text - word);
6110 completion[orig_text - word] = '\0';
6111 strcat (completion, match);
6112 }
6113
d6565258 6114 VEC_safe_push (char_ptr, *sv, completion);
41d27058
JB
6115}
6116
ccefe4c4 6117/* An object of this type is passed as the user_data argument to the
bb4142cf 6118 expand_symtabs_matching method. */
ccefe4c4
TT
6119struct add_partial_datum
6120{
6121 VEC(char_ptr) **completions;
6f937416 6122 const char *text;
ccefe4c4 6123 int text_len;
6f937416
PA
6124 const char *text0;
6125 const char *word;
ccefe4c4
TT
6126 int wild_match;
6127 int encoded;
6128};
6129
bb4142cf
DE
6130/* A callback for expand_symtabs_matching. */
6131
7b08b9eb 6132static int
bb4142cf 6133ada_complete_symbol_matcher (const char *name, void *user_data)
ccefe4c4
TT
6134{
6135 struct add_partial_datum *data = user_data;
7b08b9eb
JK
6136
6137 return symbol_completion_match (name, data->text, data->text_len,
6138 data->wild_match, data->encoded) != NULL;
ccefe4c4
TT
6139}
6140
49c4e619
TT
6141/* Return a list of possible symbol names completing TEXT0. WORD is
6142 the entire command on which completion is made. */
41d27058 6143
49c4e619 6144static VEC (char_ptr) *
6f937416
PA
6145ada_make_symbol_completion_list (const char *text0, const char *word,
6146 enum type_code code)
41d27058
JB
6147{
6148 char *text;
6149 int text_len;
b1ed564a
JB
6150 int wild_match_p;
6151 int encoded_p;
2ba95b9b 6152 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
41d27058 6153 struct symbol *sym;
43f3e411 6154 struct compunit_symtab *s;
41d27058
JB
6155 struct minimal_symbol *msymbol;
6156 struct objfile *objfile;
3977b71f 6157 const struct block *b, *surrounding_static_block = 0;
41d27058 6158 int i;
8157b174 6159 struct block_iterator iter;
b8fea896 6160 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
41d27058 6161
2f68a895
TT
6162 gdb_assert (code == TYPE_CODE_UNDEF);
6163
41d27058
JB
6164 if (text0[0] == '<')
6165 {
6166 text = xstrdup (text0);
6167 make_cleanup (xfree, text);
6168 text_len = strlen (text);
b1ed564a
JB
6169 wild_match_p = 0;
6170 encoded_p = 1;
41d27058
JB
6171 }
6172 else
6173 {
6174 text = xstrdup (ada_encode (text0));
6175 make_cleanup (xfree, text);
6176 text_len = strlen (text);
6177 for (i = 0; i < text_len; i++)
6178 text[i] = tolower (text[i]);
6179
b1ed564a 6180 encoded_p = (strstr (text0, "__") != NULL);
41d27058
JB
6181 /* If the name contains a ".", then the user is entering a fully
6182 qualified entity name, and the match must not be done in wild
6183 mode. Similarly, if the user wants to complete what looks like
6184 an encoded name, the match must not be done in wild mode. */
b1ed564a 6185 wild_match_p = (strchr (text0, '.') == NULL && !encoded_p);
41d27058
JB
6186 }
6187
6188 /* First, look at the partial symtab symbols. */
41d27058 6189 {
ccefe4c4
TT
6190 struct add_partial_datum data;
6191
6192 data.completions = &completions;
6193 data.text = text;
6194 data.text_len = text_len;
6195 data.text0 = text0;
6196 data.word = word;
b1ed564a
JB
6197 data.wild_match = wild_match_p;
6198 data.encoded = encoded_p;
bb4142cf
DE
6199 expand_symtabs_matching (NULL, ada_complete_symbol_matcher, ALL_DOMAIN,
6200 &data);
41d27058
JB
6201 }
6202
6203 /* At this point scan through the misc symbol vectors and add each
6204 symbol you find to the list. Eventually we want to ignore
6205 anything that isn't a text symbol (everything else will be
6206 handled by the psymtab code above). */
6207
6208 ALL_MSYMBOLS (objfile, msymbol)
6209 {
6210 QUIT;
efd66ac6 6211 symbol_completion_add (&completions, MSYMBOL_LINKAGE_NAME (msymbol),
b1ed564a
JB
6212 text, text_len, text0, word, wild_match_p,
6213 encoded_p);
41d27058
JB
6214 }
6215
6216 /* Search upwards from currently selected frame (so that we can
6217 complete on local vars. */
6218
6219 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6220 {
6221 if (!BLOCK_SUPERBLOCK (b))
6222 surrounding_static_block = b; /* For elmin of dups */
6223
6224 ALL_BLOCK_SYMBOLS (b, iter, sym)
6225 {
d6565258 6226 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6227 text, text_len, text0, word,
b1ed564a 6228 wild_match_p, encoded_p);
41d27058
JB
6229 }
6230 }
6231
6232 /* Go through the symtabs and check the externs and statics for
43f3e411 6233 symbols which match. */
41d27058 6234
43f3e411 6235 ALL_COMPUNITS (objfile, s)
41d27058
JB
6236 {
6237 QUIT;
43f3e411 6238 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
41d27058
JB
6239 ALL_BLOCK_SYMBOLS (b, iter, sym)
6240 {
d6565258 6241 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6242 text, text_len, text0, word,
b1ed564a 6243 wild_match_p, encoded_p);
41d27058
JB
6244 }
6245 }
6246
43f3e411 6247 ALL_COMPUNITS (objfile, s)
41d27058
JB
6248 {
6249 QUIT;
43f3e411 6250 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
41d27058
JB
6251 /* Don't do this block twice. */
6252 if (b == surrounding_static_block)
6253 continue;
6254 ALL_BLOCK_SYMBOLS (b, iter, sym)
6255 {
d6565258 6256 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6257 text, text_len, text0, word,
b1ed564a 6258 wild_match_p, encoded_p);
41d27058
JB
6259 }
6260 }
6261
b8fea896 6262 do_cleanups (old_chain);
49c4e619 6263 return completions;
41d27058
JB
6264}
6265
963a6417 6266 /* Field Access */
96d887e8 6267
73fb9985
JB
6268/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6269 for tagged types. */
6270
6271static int
6272ada_is_dispatch_table_ptr_type (struct type *type)
6273{
0d5cff50 6274 const char *name;
73fb9985
JB
6275
6276 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6277 return 0;
6278
6279 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6280 if (name == NULL)
6281 return 0;
6282
6283 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6284}
6285
ac4a2da4
JG
6286/* Return non-zero if TYPE is an interface tag. */
6287
6288static int
6289ada_is_interface_tag (struct type *type)
6290{
6291 const char *name = TYPE_NAME (type);
6292
6293 if (name == NULL)
6294 return 0;
6295
6296 return (strcmp (name, "ada__tags__interface_tag") == 0);
6297}
6298
963a6417
PH
6299/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6300 to be invisible to users. */
96d887e8 6301
963a6417
PH
6302int
6303ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6304{
963a6417
PH
6305 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6306 return 1;
ffde82bf 6307
73fb9985
JB
6308 /* Check the name of that field. */
6309 {
6310 const char *name = TYPE_FIELD_NAME (type, field_num);
6311
6312 /* Anonymous field names should not be printed.
6313 brobecker/2007-02-20: I don't think this can actually happen
6314 but we don't want to print the value of annonymous fields anyway. */
6315 if (name == NULL)
6316 return 1;
6317
ffde82bf
JB
6318 /* Normally, fields whose name start with an underscore ("_")
6319 are fields that have been internally generated by the compiler,
6320 and thus should not be printed. The "_parent" field is special,
6321 however: This is a field internally generated by the compiler
6322 for tagged types, and it contains the components inherited from
6323 the parent type. This field should not be printed as is, but
6324 should not be ignored either. */
73fb9985
JB
6325 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
6326 return 1;
6327 }
6328
ac4a2da4
JG
6329 /* If this is the dispatch table of a tagged type or an interface tag,
6330 then ignore. */
73fb9985 6331 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6332 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6333 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6334 return 1;
6335
6336 /* Not a special field, so it should not be ignored. */
6337 return 0;
963a6417 6338}
96d887e8 6339
963a6417 6340/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6341 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6342
963a6417
PH
6343int
6344ada_is_tagged_type (struct type *type, int refok)
6345{
6346 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
6347}
96d887e8 6348
963a6417 6349/* True iff TYPE represents the type of X'Tag */
96d887e8 6350
963a6417
PH
6351int
6352ada_is_tag_type (struct type *type)
6353{
6354 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6355 return 0;
6356 else
96d887e8 6357 {
963a6417 6358 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6359
963a6417
PH
6360 return (name != NULL
6361 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6362 }
96d887e8
PH
6363}
6364
963a6417 6365/* The type of the tag on VAL. */
76a01679 6366
963a6417
PH
6367struct type *
6368ada_tag_type (struct value *val)
96d887e8 6369{
df407dfe 6370 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
963a6417 6371}
96d887e8 6372
b50d69b5
JG
6373/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6374 retired at Ada 05). */
6375
6376static int
6377is_ada95_tag (struct value *tag)
6378{
6379 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6380}
6381
963a6417 6382/* The value of the tag on VAL. */
96d887e8 6383
963a6417
PH
6384struct value *
6385ada_value_tag (struct value *val)
6386{
03ee6b2e 6387 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6388}
6389
963a6417
PH
6390/* The value of the tag on the object of type TYPE whose contents are
6391 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6392 ADDRESS. */
96d887e8 6393
963a6417 6394static struct value *
10a2c479 6395value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6396 const gdb_byte *valaddr,
963a6417 6397 CORE_ADDR address)
96d887e8 6398{
b5385fc0 6399 int tag_byte_offset;
963a6417 6400 struct type *tag_type;
5b4ee69b 6401
963a6417 6402 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6403 NULL, NULL, NULL))
96d887e8 6404 {
fc1a4b47 6405 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6406 ? NULL
6407 : valaddr + tag_byte_offset);
963a6417 6408 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6409
963a6417 6410 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6411 }
963a6417
PH
6412 return NULL;
6413}
96d887e8 6414
963a6417
PH
6415static struct type *
6416type_from_tag (struct value *tag)
6417{
6418 const char *type_name = ada_tag_name (tag);
5b4ee69b 6419
963a6417
PH
6420 if (type_name != NULL)
6421 return ada_find_any_type (ada_encode (type_name));
6422 return NULL;
6423}
96d887e8 6424
b50d69b5
JG
6425/* Given a value OBJ of a tagged type, return a value of this
6426 type at the base address of the object. The base address, as
6427 defined in Ada.Tags, it is the address of the primary tag of
6428 the object, and therefore where the field values of its full
6429 view can be fetched. */
6430
6431struct value *
6432ada_tag_value_at_base_address (struct value *obj)
6433{
6434 volatile struct gdb_exception e;
6435 struct value *val;
6436 LONGEST offset_to_top = 0;
6437 struct type *ptr_type, *obj_type;
6438 struct value *tag;
6439 CORE_ADDR base_address;
6440
6441 obj_type = value_type (obj);
6442
6443 /* It is the responsability of the caller to deref pointers. */
6444
6445 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6446 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6447 return obj;
6448
6449 tag = ada_value_tag (obj);
6450 if (!tag)
6451 return obj;
6452
6453 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6454
6455 if (is_ada95_tag (tag))
6456 return obj;
6457
6458 ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
6459 ptr_type = lookup_pointer_type (ptr_type);
6460 val = value_cast (ptr_type, tag);
6461 if (!val)
6462 return obj;
6463
6464 /* It is perfectly possible that an exception be raised while
6465 trying to determine the base address, just like for the tag;
6466 see ada_tag_name for more details. We do not print the error
6467 message for the same reason. */
6468
6469 TRY_CATCH (e, RETURN_MASK_ERROR)
6470 {
6471 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6472 }
6473
6474 if (e.reason < 0)
6475 return obj;
6476
6477 /* If offset is null, nothing to do. */
6478
6479 if (offset_to_top == 0)
6480 return obj;
6481
6482 /* -1 is a special case in Ada.Tags; however, what should be done
6483 is not quite clear from the documentation. So do nothing for
6484 now. */
6485
6486 if (offset_to_top == -1)
6487 return obj;
6488
6489 base_address = value_address (obj) - offset_to_top;
6490 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6491
6492 /* Make sure that we have a proper tag at the new address.
6493 Otherwise, offset_to_top is bogus (which can happen when
6494 the object is not initialized yet). */
6495
6496 if (!tag)
6497 return obj;
6498
6499 obj_type = type_from_tag (tag);
6500
6501 if (!obj_type)
6502 return obj;
6503
6504 return value_from_contents_and_address (obj_type, NULL, base_address);
6505}
6506
1b611343
JB
6507/* Return the "ada__tags__type_specific_data" type. */
6508
6509static struct type *
6510ada_get_tsd_type (struct inferior *inf)
963a6417 6511{
1b611343 6512 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6513
1b611343
JB
6514 if (data->tsd_type == 0)
6515 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6516 return data->tsd_type;
6517}
529cad9c 6518
1b611343
JB
6519/* Return the TSD (type-specific data) associated to the given TAG.
6520 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6521
1b611343 6522 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6523
1b611343
JB
6524static struct value *
6525ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6526{
4c4b4cd2 6527 struct value *val;
1b611343 6528 struct type *type;
5b4ee69b 6529
1b611343
JB
6530 /* First option: The TSD is simply stored as a field of our TAG.
6531 Only older versions of GNAT would use this format, but we have
6532 to test it first, because there are no visible markers for
6533 the current approach except the absence of that field. */
529cad9c 6534
1b611343
JB
6535 val = ada_value_struct_elt (tag, "tsd", 1);
6536 if (val)
6537 return val;
e802dbe0 6538
1b611343
JB
6539 /* Try the second representation for the dispatch table (in which
6540 there is no explicit 'tsd' field in the referent of the tag pointer,
6541 and instead the tsd pointer is stored just before the dispatch
6542 table. */
e802dbe0 6543
1b611343
JB
6544 type = ada_get_tsd_type (current_inferior());
6545 if (type == NULL)
6546 return NULL;
6547 type = lookup_pointer_type (lookup_pointer_type (type));
6548 val = value_cast (type, tag);
6549 if (val == NULL)
6550 return NULL;
6551 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6552}
6553
1b611343
JB
6554/* Given the TSD of a tag (type-specific data), return a string
6555 containing the name of the associated type.
6556
6557 The returned value is good until the next call. May return NULL
6558 if we are unable to determine the tag name. */
6559
6560static char *
6561ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6562{
529cad9c
PH
6563 static char name[1024];
6564 char *p;
1b611343 6565 struct value *val;
529cad9c 6566
1b611343 6567 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6568 if (val == NULL)
1b611343 6569 return NULL;
4c4b4cd2
PH
6570 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6571 for (p = name; *p != '\0'; p += 1)
6572 if (isalpha (*p))
6573 *p = tolower (*p);
1b611343 6574 return name;
4c4b4cd2
PH
6575}
6576
6577/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6578 a C string.
6579
6580 Return NULL if the TAG is not an Ada tag, or if we were unable to
6581 determine the name of that tag. The result is good until the next
6582 call. */
4c4b4cd2
PH
6583
6584const char *
6585ada_tag_name (struct value *tag)
6586{
1b611343
JB
6587 volatile struct gdb_exception e;
6588 char *name = NULL;
5b4ee69b 6589
df407dfe 6590 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6591 return NULL;
1b611343
JB
6592
6593 /* It is perfectly possible that an exception be raised while trying
6594 to determine the TAG's name, even under normal circumstances:
6595 The associated variable may be uninitialized or corrupted, for
6596 instance. We do not let any exception propagate past this point.
6597 instead we return NULL.
6598
6599 We also do not print the error message either (which often is very
6600 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6601 the caller print a more meaningful message if necessary. */
6602 TRY_CATCH (e, RETURN_MASK_ERROR)
6603 {
6604 struct value *tsd = ada_get_tsd_from_tag (tag);
6605
6606 if (tsd != NULL)
6607 name = ada_tag_name_from_tsd (tsd);
6608 }
6609
6610 return name;
4c4b4cd2
PH
6611}
6612
6613/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6614
d2e4a39e 6615struct type *
ebf56fd3 6616ada_parent_type (struct type *type)
14f9c5c9
AS
6617{
6618 int i;
6619
61ee279c 6620 type = ada_check_typedef (type);
14f9c5c9
AS
6621
6622 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6623 return NULL;
6624
6625 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6626 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6627 {
6628 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6629
6630 /* If the _parent field is a pointer, then dereference it. */
6631 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6632 parent_type = TYPE_TARGET_TYPE (parent_type);
6633 /* If there is a parallel XVS type, get the actual base type. */
6634 parent_type = ada_get_base_type (parent_type);
6635
6636 return ada_check_typedef (parent_type);
6637 }
14f9c5c9
AS
6638
6639 return NULL;
6640}
6641
4c4b4cd2
PH
6642/* True iff field number FIELD_NUM of structure type TYPE contains the
6643 parent-type (inherited) fields of a derived type. Assumes TYPE is
6644 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6645
6646int
ebf56fd3 6647ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6648{
61ee279c 6649 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6650
4c4b4cd2
PH
6651 return (name != NULL
6652 && (strncmp (name, "PARENT", 6) == 0
6653 || strncmp (name, "_parent", 7) == 0));
14f9c5c9
AS
6654}
6655
4c4b4cd2 6656/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6657 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6658 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6659 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6660 structures. */
14f9c5c9
AS
6661
6662int
ebf56fd3 6663ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6664{
d2e4a39e 6665 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6666
d2e4a39e 6667 return (name != NULL
4c4b4cd2
PH
6668 && (strncmp (name, "PARENT", 6) == 0
6669 || strcmp (name, "REP") == 0
6670 || strncmp (name, "_parent", 7) == 0
6671 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6672}
6673
4c4b4cd2
PH
6674/* True iff field number FIELD_NUM of structure or union type TYPE
6675 is a variant wrapper. Assumes TYPE is a structure type with at least
6676 FIELD_NUM+1 fields. */
14f9c5c9
AS
6677
6678int
ebf56fd3 6679ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6680{
d2e4a39e 6681 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6682
14f9c5c9 6683 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6684 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6685 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6686 == TYPE_CODE_UNION)));
14f9c5c9
AS
6687}
6688
6689/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6690 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6691 returns the type of the controlling discriminant for the variant.
6692 May return NULL if the type could not be found. */
14f9c5c9 6693
d2e4a39e 6694struct type *
ebf56fd3 6695ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6696{
d2e4a39e 6697 char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6698
7c964f07 6699 return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
14f9c5c9
AS
6700}
6701
4c4b4cd2 6702/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6703 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6704 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6705
6706int
ebf56fd3 6707ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6708{
d2e4a39e 6709 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6710
14f9c5c9
AS
6711 return (name != NULL && name[0] == 'O');
6712}
6713
6714/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
6715 returns the name of the discriminant controlling the variant.
6716 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 6717
d2e4a39e 6718char *
ebf56fd3 6719ada_variant_discrim_name (struct type *type0)
14f9c5c9 6720{
d2e4a39e 6721 static char *result = NULL;
14f9c5c9 6722 static size_t result_len = 0;
d2e4a39e
AS
6723 struct type *type;
6724 const char *name;
6725 const char *discrim_end;
6726 const char *discrim_start;
14f9c5c9
AS
6727
6728 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6729 type = TYPE_TARGET_TYPE (type0);
6730 else
6731 type = type0;
6732
6733 name = ada_type_name (type);
6734
6735 if (name == NULL || name[0] == '\000')
6736 return "";
6737
6738 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6739 discrim_end -= 1)
6740 {
4c4b4cd2
PH
6741 if (strncmp (discrim_end, "___XVN", 6) == 0)
6742 break;
14f9c5c9
AS
6743 }
6744 if (discrim_end == name)
6745 return "";
6746
d2e4a39e 6747 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
6748 discrim_start -= 1)
6749 {
d2e4a39e 6750 if (discrim_start == name + 1)
4c4b4cd2 6751 return "";
76a01679 6752 if ((discrim_start > name + 3
4c4b4cd2
PH
6753 && strncmp (discrim_start - 3, "___", 3) == 0)
6754 || discrim_start[-1] == '.')
6755 break;
14f9c5c9
AS
6756 }
6757
6758 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6759 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 6760 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
6761 return result;
6762}
6763
4c4b4cd2
PH
6764/* Scan STR for a subtype-encoded number, beginning at position K.
6765 Put the position of the character just past the number scanned in
6766 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6767 Return 1 if there was a valid number at the given position, and 0
6768 otherwise. A "subtype-encoded" number consists of the absolute value
6769 in decimal, followed by the letter 'm' to indicate a negative number.
6770 Assumes 0m does not occur. */
14f9c5c9
AS
6771
6772int
d2e4a39e 6773ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
6774{
6775 ULONGEST RU;
6776
d2e4a39e 6777 if (!isdigit (str[k]))
14f9c5c9
AS
6778 return 0;
6779
4c4b4cd2 6780 /* Do it the hard way so as not to make any assumption about
14f9c5c9 6781 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 6782 LONGEST. */
14f9c5c9
AS
6783 RU = 0;
6784 while (isdigit (str[k]))
6785 {
d2e4a39e 6786 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
6787 k += 1;
6788 }
6789
d2e4a39e 6790 if (str[k] == 'm')
14f9c5c9
AS
6791 {
6792 if (R != NULL)
4c4b4cd2 6793 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
6794 k += 1;
6795 }
6796 else if (R != NULL)
6797 *R = (LONGEST) RU;
6798
4c4b4cd2 6799 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
6800 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6801 number representable as a LONGEST (although either would probably work
6802 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 6803 above is always equivalent to the negative of RU. */
14f9c5c9
AS
6804
6805 if (new_k != NULL)
6806 *new_k = k;
6807 return 1;
6808}
6809
4c4b4cd2
PH
6810/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6811 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6812 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 6813
d2e4a39e 6814int
ebf56fd3 6815ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 6816{
d2e4a39e 6817 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
6818 int p;
6819
6820 p = 0;
6821 while (1)
6822 {
d2e4a39e 6823 switch (name[p])
4c4b4cd2
PH
6824 {
6825 case '\0':
6826 return 0;
6827 case 'S':
6828 {
6829 LONGEST W;
5b4ee69b 6830
4c4b4cd2
PH
6831 if (!ada_scan_number (name, p + 1, &W, &p))
6832 return 0;
6833 if (val == W)
6834 return 1;
6835 break;
6836 }
6837 case 'R':
6838 {
6839 LONGEST L, U;
5b4ee69b 6840
4c4b4cd2
PH
6841 if (!ada_scan_number (name, p + 1, &L, &p)
6842 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6843 return 0;
6844 if (val >= L && val <= U)
6845 return 1;
6846 break;
6847 }
6848 case 'O':
6849 return 1;
6850 default:
6851 return 0;
6852 }
6853 }
6854}
6855
0963b4bd 6856/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
6857
6858/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6859 ARG_TYPE, extract and return the value of one of its (non-static)
6860 fields. FIELDNO says which field. Differs from value_primitive_field
6861 only in that it can handle packed values of arbitrary type. */
14f9c5c9 6862
4c4b4cd2 6863static struct value *
d2e4a39e 6864ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 6865 struct type *arg_type)
14f9c5c9 6866{
14f9c5c9
AS
6867 struct type *type;
6868
61ee279c 6869 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
6870 type = TYPE_FIELD_TYPE (arg_type, fieldno);
6871
4c4b4cd2 6872 /* Handle packed fields. */
14f9c5c9
AS
6873
6874 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
6875 {
6876 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6877 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 6878
0fd88904 6879 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
6880 offset + bit_pos / 8,
6881 bit_pos % 8, bit_size, type);
14f9c5c9
AS
6882 }
6883 else
6884 return value_primitive_field (arg1, offset, fieldno, arg_type);
6885}
6886
52ce6436
PH
6887/* Find field with name NAME in object of type TYPE. If found,
6888 set the following for each argument that is non-null:
6889 - *FIELD_TYPE_P to the field's type;
6890 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6891 an object of that type;
6892 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6893 - *BIT_SIZE_P to its size in bits if the field is packed, and
6894 0 otherwise;
6895 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6896 fields up to but not including the desired field, or by the total
6897 number of fields if not found. A NULL value of NAME never
6898 matches; the function just counts visible fields in this case.
6899
0963b4bd 6900 Returns 1 if found, 0 otherwise. */
52ce6436 6901
4c4b4cd2 6902static int
0d5cff50 6903find_struct_field (const char *name, struct type *type, int offset,
76a01679 6904 struct type **field_type_p,
52ce6436
PH
6905 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6906 int *index_p)
4c4b4cd2
PH
6907{
6908 int i;
6909
61ee279c 6910 type = ada_check_typedef (type);
76a01679 6911
52ce6436
PH
6912 if (field_type_p != NULL)
6913 *field_type_p = NULL;
6914 if (byte_offset_p != NULL)
d5d6fca5 6915 *byte_offset_p = 0;
52ce6436
PH
6916 if (bit_offset_p != NULL)
6917 *bit_offset_p = 0;
6918 if (bit_size_p != NULL)
6919 *bit_size_p = 0;
6920
6921 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
6922 {
6923 int bit_pos = TYPE_FIELD_BITPOS (type, i);
6924 int fld_offset = offset + bit_pos / 8;
0d5cff50 6925 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 6926
4c4b4cd2
PH
6927 if (t_field_name == NULL)
6928 continue;
6929
52ce6436 6930 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
6931 {
6932 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 6933
52ce6436
PH
6934 if (field_type_p != NULL)
6935 *field_type_p = TYPE_FIELD_TYPE (type, i);
6936 if (byte_offset_p != NULL)
6937 *byte_offset_p = fld_offset;
6938 if (bit_offset_p != NULL)
6939 *bit_offset_p = bit_pos % 8;
6940 if (bit_size_p != NULL)
6941 *bit_size_p = bit_size;
76a01679
JB
6942 return 1;
6943 }
4c4b4cd2
PH
6944 else if (ada_is_wrapper_field (type, i))
6945 {
52ce6436
PH
6946 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
6947 field_type_p, byte_offset_p, bit_offset_p,
6948 bit_size_p, index_p))
76a01679
JB
6949 return 1;
6950 }
4c4b4cd2
PH
6951 else if (ada_is_variant_part (type, i))
6952 {
52ce6436
PH
6953 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6954 fixed type?? */
4c4b4cd2 6955 int j;
52ce6436
PH
6956 struct type *field_type
6957 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 6958
52ce6436 6959 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6960 {
76a01679
JB
6961 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
6962 fld_offset
6963 + TYPE_FIELD_BITPOS (field_type, j) / 8,
6964 field_type_p, byte_offset_p,
52ce6436 6965 bit_offset_p, bit_size_p, index_p))
76a01679 6966 return 1;
4c4b4cd2
PH
6967 }
6968 }
52ce6436
PH
6969 else if (index_p != NULL)
6970 *index_p += 1;
4c4b4cd2
PH
6971 }
6972 return 0;
6973}
6974
0963b4bd 6975/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 6976
52ce6436
PH
6977static int
6978num_visible_fields (struct type *type)
6979{
6980 int n;
5b4ee69b 6981
52ce6436
PH
6982 n = 0;
6983 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6984 return n;
6985}
14f9c5c9 6986
4c4b4cd2 6987/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
6988 and search in it assuming it has (class) type TYPE.
6989 If found, return value, else return NULL.
6990
4c4b4cd2 6991 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 6992
4c4b4cd2 6993static struct value *
d2e4a39e 6994ada_search_struct_field (char *name, struct value *arg, int offset,
4c4b4cd2 6995 struct type *type)
14f9c5c9
AS
6996{
6997 int i;
14f9c5c9 6998
5b4ee69b 6999 type = ada_check_typedef (type);
52ce6436 7000 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 7001 {
0d5cff50 7002 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7003
7004 if (t_field_name == NULL)
4c4b4cd2 7005 continue;
14f9c5c9
AS
7006
7007 else if (field_name_match (t_field_name, name))
4c4b4cd2 7008 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
7009
7010 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7011 {
0963b4bd 7012 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
7013 ada_search_struct_field (name, arg,
7014 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7015 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7016
4c4b4cd2
PH
7017 if (v != NULL)
7018 return v;
7019 }
14f9c5c9
AS
7020
7021 else if (ada_is_variant_part (type, i))
4c4b4cd2 7022 {
0963b4bd 7023 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 7024 int j;
5b4ee69b
MS
7025 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7026 i));
4c4b4cd2
PH
7027 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7028
52ce6436 7029 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7030 {
0963b4bd
MS
7031 struct value *v = ada_search_struct_field /* Force line
7032 break. */
06d5cf63
JB
7033 (name, arg,
7034 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7035 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 7036
4c4b4cd2
PH
7037 if (v != NULL)
7038 return v;
7039 }
7040 }
14f9c5c9
AS
7041 }
7042 return NULL;
7043}
d2e4a39e 7044
52ce6436
PH
7045static struct value *ada_index_struct_field_1 (int *, struct value *,
7046 int, struct type *);
7047
7048
7049/* Return field #INDEX in ARG, where the index is that returned by
7050 * find_struct_field through its INDEX_P argument. Adjust the address
7051 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 7052 * If found, return value, else return NULL. */
52ce6436
PH
7053
7054static struct value *
7055ada_index_struct_field (int index, struct value *arg, int offset,
7056 struct type *type)
7057{
7058 return ada_index_struct_field_1 (&index, arg, offset, type);
7059}
7060
7061
7062/* Auxiliary function for ada_index_struct_field. Like
7063 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 7064 * *INDEX_P. */
52ce6436
PH
7065
7066static struct value *
7067ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7068 struct type *type)
7069{
7070 int i;
7071 type = ada_check_typedef (type);
7072
7073 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7074 {
7075 if (TYPE_FIELD_NAME (type, i) == NULL)
7076 continue;
7077 else if (ada_is_wrapper_field (type, i))
7078 {
0963b4bd 7079 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
7080 ada_index_struct_field_1 (index_p, arg,
7081 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7082 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7083
52ce6436
PH
7084 if (v != NULL)
7085 return v;
7086 }
7087
7088 else if (ada_is_variant_part (type, i))
7089 {
7090 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 7091 find_struct_field. */
52ce6436
PH
7092 error (_("Cannot assign this kind of variant record"));
7093 }
7094 else if (*index_p == 0)
7095 return ada_value_primitive_field (arg, offset, i, type);
7096 else
7097 *index_p -= 1;
7098 }
7099 return NULL;
7100}
7101
4c4b4cd2
PH
7102/* Given ARG, a value of type (pointer or reference to a)*
7103 structure/union, extract the component named NAME from the ultimate
7104 target structure/union and return it as a value with its
f5938064 7105 appropriate type.
14f9c5c9 7106
4c4b4cd2
PH
7107 The routine searches for NAME among all members of the structure itself
7108 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7109 (e.g., '_parent').
7110
03ee6b2e
PH
7111 If NO_ERR, then simply return NULL in case of error, rather than
7112 calling error. */
14f9c5c9 7113
d2e4a39e 7114struct value *
03ee6b2e 7115ada_value_struct_elt (struct value *arg, char *name, int no_err)
14f9c5c9 7116{
4c4b4cd2 7117 struct type *t, *t1;
d2e4a39e 7118 struct value *v;
14f9c5c9 7119
4c4b4cd2 7120 v = NULL;
df407dfe 7121 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
7122 if (TYPE_CODE (t) == TYPE_CODE_REF)
7123 {
7124 t1 = TYPE_TARGET_TYPE (t);
7125 if (t1 == NULL)
03ee6b2e 7126 goto BadValue;
61ee279c 7127 t1 = ada_check_typedef (t1);
4c4b4cd2 7128 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 7129 {
994b9211 7130 arg = coerce_ref (arg);
76a01679
JB
7131 t = t1;
7132 }
4c4b4cd2 7133 }
14f9c5c9 7134
4c4b4cd2
PH
7135 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7136 {
7137 t1 = TYPE_TARGET_TYPE (t);
7138 if (t1 == NULL)
03ee6b2e 7139 goto BadValue;
61ee279c 7140 t1 = ada_check_typedef (t1);
4c4b4cd2 7141 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7142 {
7143 arg = value_ind (arg);
7144 t = t1;
7145 }
4c4b4cd2 7146 else
76a01679 7147 break;
4c4b4cd2 7148 }
14f9c5c9 7149
4c4b4cd2 7150 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 7151 goto BadValue;
14f9c5c9 7152
4c4b4cd2
PH
7153 if (t1 == t)
7154 v = ada_search_struct_field (name, arg, 0, t);
7155 else
7156 {
7157 int bit_offset, bit_size, byte_offset;
7158 struct type *field_type;
7159 CORE_ADDR address;
7160
76a01679 7161 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 7162 address = value_address (ada_value_ind (arg));
4c4b4cd2 7163 else
b50d69b5 7164 address = value_address (ada_coerce_ref (arg));
14f9c5c9 7165
1ed6ede0 7166 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
76a01679
JB
7167 if (find_struct_field (name, t1, 0,
7168 &field_type, &byte_offset, &bit_offset,
52ce6436 7169 &bit_size, NULL))
76a01679
JB
7170 {
7171 if (bit_size != 0)
7172 {
714e53ab
PH
7173 if (TYPE_CODE (t) == TYPE_CODE_REF)
7174 arg = ada_coerce_ref (arg);
7175 else
7176 arg = ada_value_ind (arg);
76a01679
JB
7177 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7178 bit_offset, bit_size,
7179 field_type);
7180 }
7181 else
f5938064 7182 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
7183 }
7184 }
7185
03ee6b2e
PH
7186 if (v != NULL || no_err)
7187 return v;
7188 else
323e0a4a 7189 error (_("There is no member named %s."), name);
14f9c5c9 7190
03ee6b2e
PH
7191 BadValue:
7192 if (no_err)
7193 return NULL;
7194 else
0963b4bd
MS
7195 error (_("Attempt to extract a component of "
7196 "a value that is not a record."));
14f9c5c9
AS
7197}
7198
7199/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7200 If DISPP is non-null, add its byte displacement from the beginning of a
7201 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7202 work for packed fields).
7203
7204 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7205 followed by "___".
14f9c5c9 7206
0963b4bd 7207 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
7208 be a (pointer or reference)+ to a struct or union, and the
7209 ultimate target type will be searched.
14f9c5c9
AS
7210
7211 Looks recursively into variant clauses and parent types.
7212
4c4b4cd2
PH
7213 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7214 TYPE is not a type of the right kind. */
14f9c5c9 7215
4c4b4cd2 7216static struct type *
76a01679
JB
7217ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
7218 int noerr, int *dispp)
14f9c5c9
AS
7219{
7220 int i;
7221
7222 if (name == NULL)
7223 goto BadName;
7224
76a01679 7225 if (refok && type != NULL)
4c4b4cd2
PH
7226 while (1)
7227 {
61ee279c 7228 type = ada_check_typedef (type);
76a01679
JB
7229 if (TYPE_CODE (type) != TYPE_CODE_PTR
7230 && TYPE_CODE (type) != TYPE_CODE_REF)
7231 break;
7232 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7233 }
14f9c5c9 7234
76a01679 7235 if (type == NULL
1265e4aa
JB
7236 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7237 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7238 {
4c4b4cd2 7239 if (noerr)
76a01679 7240 return NULL;
4c4b4cd2 7241 else
76a01679
JB
7242 {
7243 target_terminal_ours ();
7244 gdb_flush (gdb_stdout);
323e0a4a
AC
7245 if (type == NULL)
7246 error (_("Type (null) is not a structure or union type"));
7247 else
7248 {
7249 /* XXX: type_sprint */
7250 fprintf_unfiltered (gdb_stderr, _("Type "));
7251 type_print (type, "", gdb_stderr, -1);
7252 error (_(" is not a structure or union type"));
7253 }
76a01679 7254 }
14f9c5c9
AS
7255 }
7256
7257 type = to_static_fixed_type (type);
7258
7259 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7260 {
0d5cff50 7261 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7262 struct type *t;
7263 int disp;
d2e4a39e 7264
14f9c5c9 7265 if (t_field_name == NULL)
4c4b4cd2 7266 continue;
14f9c5c9
AS
7267
7268 else if (field_name_match (t_field_name, name))
4c4b4cd2
PH
7269 {
7270 if (dispp != NULL)
7271 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
61ee279c 7272 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7273 }
14f9c5c9
AS
7274
7275 else if (ada_is_wrapper_field (type, i))
4c4b4cd2
PH
7276 {
7277 disp = 0;
7278 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7279 0, 1, &disp);
7280 if (t != NULL)
7281 {
7282 if (dispp != NULL)
7283 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7284 return t;
7285 }
7286 }
14f9c5c9
AS
7287
7288 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7289 {
7290 int j;
5b4ee69b
MS
7291 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7292 i));
4c4b4cd2
PH
7293
7294 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7295 {
b1f33ddd
JB
7296 /* FIXME pnh 2008/01/26: We check for a field that is
7297 NOT wrapped in a struct, since the compiler sometimes
7298 generates these for unchecked variant types. Revisit
0963b4bd 7299 if the compiler changes this practice. */
0d5cff50 7300 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
4c4b4cd2 7301 disp = 0;
b1f33ddd
JB
7302 if (v_field_name != NULL
7303 && field_name_match (v_field_name, name))
7304 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
7305 else
0963b4bd
MS
7306 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7307 j),
b1f33ddd
JB
7308 name, 0, 1, &disp);
7309
4c4b4cd2
PH
7310 if (t != NULL)
7311 {
7312 if (dispp != NULL)
7313 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7314 return t;
7315 }
7316 }
7317 }
14f9c5c9
AS
7318
7319 }
7320
7321BadName:
d2e4a39e 7322 if (!noerr)
14f9c5c9
AS
7323 {
7324 target_terminal_ours ();
7325 gdb_flush (gdb_stdout);
323e0a4a
AC
7326 if (name == NULL)
7327 {
7328 /* XXX: type_sprint */
7329 fprintf_unfiltered (gdb_stderr, _("Type "));
7330 type_print (type, "", gdb_stderr, -1);
7331 error (_(" has no component named <null>"));
7332 }
7333 else
7334 {
7335 /* XXX: type_sprint */
7336 fprintf_unfiltered (gdb_stderr, _("Type "));
7337 type_print (type, "", gdb_stderr, -1);
7338 error (_(" has no component named %s"), name);
7339 }
14f9c5c9
AS
7340 }
7341
7342 return NULL;
7343}
7344
b1f33ddd
JB
7345/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7346 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7347 represents an unchecked union (that is, the variant part of a
0963b4bd 7348 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7349
7350static int
7351is_unchecked_variant (struct type *var_type, struct type *outer_type)
7352{
7353 char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7354
b1f33ddd
JB
7355 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
7356 == NULL);
7357}
7358
7359
14f9c5c9
AS
7360/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7361 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7362 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7363 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7364
d2e4a39e 7365int
ebf56fd3 7366ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7367 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7368{
7369 int others_clause;
7370 int i;
d2e4a39e 7371 char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7372 struct value *outer;
7373 struct value *discrim;
14f9c5c9
AS
7374 LONGEST discrim_val;
7375
012370f6
TT
7376 /* Using plain value_from_contents_and_address here causes problems
7377 because we will end up trying to resolve a type that is currently
7378 being constructed. */
7379 outer = value_from_contents_and_address_unresolved (outer_type,
7380 outer_valaddr, 0);
0c281816
JB
7381 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7382 if (discrim == NULL)
14f9c5c9 7383 return -1;
0c281816 7384 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7385
7386 others_clause = -1;
7387 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7388 {
7389 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7390 others_clause = i;
14f9c5c9 7391 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7392 return i;
14f9c5c9
AS
7393 }
7394
7395 return others_clause;
7396}
d2e4a39e 7397\f
14f9c5c9
AS
7398
7399
4c4b4cd2 7400 /* Dynamic-Sized Records */
14f9c5c9
AS
7401
7402/* Strategy: The type ostensibly attached to a value with dynamic size
7403 (i.e., a size that is not statically recorded in the debugging
7404 data) does not accurately reflect the size or layout of the value.
7405 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7406 conventional types that are constructed on the fly. */
14f9c5c9
AS
7407
7408/* There is a subtle and tricky problem here. In general, we cannot
7409 determine the size of dynamic records without its data. However,
7410 the 'struct value' data structure, which GDB uses to represent
7411 quantities in the inferior process (the target), requires the size
7412 of the type at the time of its allocation in order to reserve space
7413 for GDB's internal copy of the data. That's why the
7414 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7415 rather than struct value*s.
14f9c5c9
AS
7416
7417 However, GDB's internal history variables ($1, $2, etc.) are
7418 struct value*s containing internal copies of the data that are not, in
7419 general, the same as the data at their corresponding addresses in
7420 the target. Fortunately, the types we give to these values are all
7421 conventional, fixed-size types (as per the strategy described
7422 above), so that we don't usually have to perform the
7423 'to_fixed_xxx_type' conversions to look at their values.
7424 Unfortunately, there is one exception: if one of the internal
7425 history variables is an array whose elements are unconstrained
7426 records, then we will need to create distinct fixed types for each
7427 element selected. */
7428
7429/* The upshot of all of this is that many routines take a (type, host
7430 address, target address) triple as arguments to represent a value.
7431 The host address, if non-null, is supposed to contain an internal
7432 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7433 target at the target address. */
14f9c5c9
AS
7434
7435/* Assuming that VAL0 represents a pointer value, the result of
7436 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7437 dynamic-sized types. */
14f9c5c9 7438
d2e4a39e
AS
7439struct value *
7440ada_value_ind (struct value *val0)
14f9c5c9 7441{
c48db5ca 7442 struct value *val = value_ind (val0);
5b4ee69b 7443
b50d69b5
JG
7444 if (ada_is_tagged_type (value_type (val), 0))
7445 val = ada_tag_value_at_base_address (val);
7446
4c4b4cd2 7447 return ada_to_fixed_value (val);
14f9c5c9
AS
7448}
7449
7450/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7451 qualifiers on VAL0. */
7452
d2e4a39e
AS
7453static struct value *
7454ada_coerce_ref (struct value *val0)
7455{
df407dfe 7456 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7457 {
7458 struct value *val = val0;
5b4ee69b 7459
994b9211 7460 val = coerce_ref (val);
b50d69b5
JG
7461
7462 if (ada_is_tagged_type (value_type (val), 0))
7463 val = ada_tag_value_at_base_address (val);
7464
4c4b4cd2 7465 return ada_to_fixed_value (val);
d2e4a39e
AS
7466 }
7467 else
14f9c5c9
AS
7468 return val0;
7469}
7470
7471/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7472 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7473
7474static unsigned int
ebf56fd3 7475align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7476{
7477 return (off + alignment - 1) & ~(alignment - 1);
7478}
7479
4c4b4cd2 7480/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7481
7482static unsigned int
ebf56fd3 7483field_alignment (struct type *type, int f)
14f9c5c9 7484{
d2e4a39e 7485 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7486 int len;
14f9c5c9
AS
7487 int align_offset;
7488
64a1bf19
JB
7489 /* The field name should never be null, unless the debugging information
7490 is somehow malformed. In this case, we assume the field does not
7491 require any alignment. */
7492 if (name == NULL)
7493 return 1;
7494
7495 len = strlen (name);
7496
4c4b4cd2
PH
7497 if (!isdigit (name[len - 1]))
7498 return 1;
14f9c5c9 7499
d2e4a39e 7500 if (isdigit (name[len - 2]))
14f9c5c9
AS
7501 align_offset = len - 2;
7502 else
7503 align_offset = len - 1;
7504
4c4b4cd2 7505 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
14f9c5c9
AS
7506 return TARGET_CHAR_BIT;
7507
4c4b4cd2
PH
7508 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7509}
7510
852dff6c 7511/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7512
852dff6c
JB
7513static struct symbol *
7514ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7515{
7516 struct symbol *sym;
7517
7518 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
4186eb54 7519 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4c4b4cd2
PH
7520 return sym;
7521
4186eb54
KS
7522 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7523 return sym;
14f9c5c9
AS
7524}
7525
dddfab26
UW
7526/* Find a type named NAME. Ignores ambiguity. This routine will look
7527 solely for types defined by debug info, it will not search the GDB
7528 primitive types. */
4c4b4cd2 7529
852dff6c 7530static struct type *
ebf56fd3 7531ada_find_any_type (const char *name)
14f9c5c9 7532{
852dff6c 7533 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7534
14f9c5c9 7535 if (sym != NULL)
dddfab26 7536 return SYMBOL_TYPE (sym);
14f9c5c9 7537
dddfab26 7538 return NULL;
14f9c5c9
AS
7539}
7540
739593e0
JB
7541/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7542 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7543 symbol, in which case it is returned. Otherwise, this looks for
7544 symbols whose name is that of NAME_SYM suffixed with "___XR".
7545 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7546
7547struct symbol *
270140bd 7548ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7549{
739593e0 7550 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7551 struct symbol *sym;
7552
739593e0
JB
7553 if (strstr (name, "___XR") != NULL)
7554 return name_sym;
7555
aeb5907d
JB
7556 sym = find_old_style_renaming_symbol (name, block);
7557
7558 if (sym != NULL)
7559 return sym;
7560
0963b4bd 7561 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7562 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7563 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7564 return sym;
7565 else
7566 return NULL;
7567}
7568
7569static struct symbol *
270140bd 7570find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 7571{
7f0df278 7572 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
7573 char *rename;
7574
7575 if (function_sym != NULL)
7576 {
7577 /* If the symbol is defined inside a function, NAME is not fully
7578 qualified. This means we need to prepend the function name
7579 as well as adding the ``___XR'' suffix to build the name of
7580 the associated renaming symbol. */
0d5cff50 7581 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
7582 /* Function names sometimes contain suffixes used
7583 for instance to qualify nested subprograms. When building
7584 the XR type name, we need to make sure that this suffix is
7585 not included. So do not include any suffix in the function
7586 name length below. */
69fadcdf 7587 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
7588 const int rename_len = function_name_len + 2 /* "__" */
7589 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 7590
529cad9c 7591 /* Strip the suffix if necessary. */
69fadcdf
JB
7592 ada_remove_trailing_digits (function_name, &function_name_len);
7593 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7594 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 7595
4c4b4cd2
PH
7596 /* Library-level functions are a special case, as GNAT adds
7597 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 7598 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
7599 have this prefix, so we need to skip this prefix if present. */
7600 if (function_name_len > 5 /* "_ada_" */
7601 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
7602 {
7603 function_name += 5;
7604 function_name_len -= 5;
7605 }
4c4b4cd2
PH
7606
7607 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
7608 strncpy (rename, function_name, function_name_len);
7609 xsnprintf (rename + function_name_len, rename_len - function_name_len,
7610 "__%s___XR", name);
4c4b4cd2
PH
7611 }
7612 else
7613 {
7614 const int rename_len = strlen (name) + 6;
5b4ee69b 7615
4c4b4cd2 7616 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 7617 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
7618 }
7619
852dff6c 7620 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
7621}
7622
14f9c5c9 7623/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 7624 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 7625 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
7626 otherwise return 0. */
7627
14f9c5c9 7628int
d2e4a39e 7629ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
7630{
7631 if (type1 == NULL)
7632 return 1;
7633 else if (type0 == NULL)
7634 return 0;
7635 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7636 return 1;
7637 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7638 return 0;
4c4b4cd2
PH
7639 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7640 return 1;
ad82864c 7641 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 7642 return 1;
4c4b4cd2
PH
7643 else if (ada_is_array_descriptor_type (type0)
7644 && !ada_is_array_descriptor_type (type1))
14f9c5c9 7645 return 1;
aeb5907d
JB
7646 else
7647 {
7648 const char *type0_name = type_name_no_tag (type0);
7649 const char *type1_name = type_name_no_tag (type1);
7650
7651 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7652 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7653 return 1;
7654 }
14f9c5c9
AS
7655 return 0;
7656}
7657
7658/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
7659 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7660
0d5cff50 7661const char *
d2e4a39e 7662ada_type_name (struct type *type)
14f9c5c9 7663{
d2e4a39e 7664 if (type == NULL)
14f9c5c9
AS
7665 return NULL;
7666 else if (TYPE_NAME (type) != NULL)
7667 return TYPE_NAME (type);
7668 else
7669 return TYPE_TAG_NAME (type);
7670}
7671
b4ba55a1
JB
7672/* Search the list of "descriptive" types associated to TYPE for a type
7673 whose name is NAME. */
7674
7675static struct type *
7676find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7677{
7678 struct type *result;
7679
c6044dd1
JB
7680 if (ada_ignore_descriptive_types_p)
7681 return NULL;
7682
b4ba55a1
JB
7683 /* If there no descriptive-type info, then there is no parallel type
7684 to be found. */
7685 if (!HAVE_GNAT_AUX_INFO (type))
7686 return NULL;
7687
7688 result = TYPE_DESCRIPTIVE_TYPE (type);
7689 while (result != NULL)
7690 {
0d5cff50 7691 const char *result_name = ada_type_name (result);
b4ba55a1
JB
7692
7693 if (result_name == NULL)
7694 {
7695 warning (_("unexpected null name on descriptive type"));
7696 return NULL;
7697 }
7698
7699 /* If the names match, stop. */
7700 if (strcmp (result_name, name) == 0)
7701 break;
7702
7703 /* Otherwise, look at the next item on the list, if any. */
7704 if (HAVE_GNAT_AUX_INFO (result))
7705 result = TYPE_DESCRIPTIVE_TYPE (result);
7706 else
7707 result = NULL;
7708 }
7709
7710 /* If we didn't find a match, see whether this is a packed array. With
7711 older compilers, the descriptive type information is either absent or
7712 irrelevant when it comes to packed arrays so the above lookup fails.
7713 Fall back to using a parallel lookup by name in this case. */
12ab9e09 7714 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
7715 return ada_find_any_type (name);
7716
7717 return result;
7718}
7719
7720/* Find a parallel type to TYPE with the specified NAME, using the
7721 descriptive type taken from the debugging information, if available,
7722 and otherwise using the (slower) name-based method. */
7723
7724static struct type *
7725ada_find_parallel_type_with_name (struct type *type, const char *name)
7726{
7727 struct type *result = NULL;
7728
7729 if (HAVE_GNAT_AUX_INFO (type))
7730 result = find_parallel_type_by_descriptive_type (type, name);
7731 else
7732 result = ada_find_any_type (name);
7733
7734 return result;
7735}
7736
7737/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 7738 SUFFIX to the name of TYPE. */
14f9c5c9 7739
d2e4a39e 7740struct type *
ebf56fd3 7741ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 7742{
0d5cff50
DE
7743 char *name;
7744 const char *typename = ada_type_name (type);
14f9c5c9 7745 int len;
d2e4a39e 7746
14f9c5c9
AS
7747 if (typename == NULL)
7748 return NULL;
7749
7750 len = strlen (typename);
7751
b4ba55a1 7752 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9
AS
7753
7754 strcpy (name, typename);
7755 strcpy (name + len, suffix);
7756
b4ba55a1 7757 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
7758}
7759
14f9c5c9 7760/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 7761 type describing its fields. Otherwise, return NULL. */
14f9c5c9 7762
d2e4a39e
AS
7763static struct type *
7764dynamic_template_type (struct type *type)
14f9c5c9 7765{
61ee279c 7766 type = ada_check_typedef (type);
14f9c5c9
AS
7767
7768 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 7769 || ada_type_name (type) == NULL)
14f9c5c9 7770 return NULL;
d2e4a39e 7771 else
14f9c5c9
AS
7772 {
7773 int len = strlen (ada_type_name (type));
5b4ee69b 7774
4c4b4cd2
PH
7775 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7776 return type;
14f9c5c9 7777 else
4c4b4cd2 7778 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
7779 }
7780}
7781
7782/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 7783 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 7784
d2e4a39e
AS
7785static int
7786is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
7787{
7788 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 7789
d2e4a39e 7790 return name != NULL
14f9c5c9
AS
7791 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
7792 && strstr (name, "___XVL") != NULL;
7793}
7794
4c4b4cd2
PH
7795/* The index of the variant field of TYPE, or -1 if TYPE does not
7796 represent a variant record type. */
14f9c5c9 7797
d2e4a39e 7798static int
4c4b4cd2 7799variant_field_index (struct type *type)
14f9c5c9
AS
7800{
7801 int f;
7802
4c4b4cd2
PH
7803 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
7804 return -1;
7805
7806 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
7807 {
7808 if (ada_is_variant_part (type, f))
7809 return f;
7810 }
7811 return -1;
14f9c5c9
AS
7812}
7813
4c4b4cd2
PH
7814/* A record type with no fields. */
7815
d2e4a39e 7816static struct type *
e9bb382b 7817empty_record (struct type *template)
14f9c5c9 7818{
e9bb382b 7819 struct type *type = alloc_type_copy (template);
5b4ee69b 7820
14f9c5c9
AS
7821 TYPE_CODE (type) = TYPE_CODE_STRUCT;
7822 TYPE_NFIELDS (type) = 0;
7823 TYPE_FIELDS (type) = NULL;
b1f33ddd 7824 INIT_CPLUS_SPECIFIC (type);
14f9c5c9
AS
7825 TYPE_NAME (type) = "<empty>";
7826 TYPE_TAG_NAME (type) = NULL;
14f9c5c9
AS
7827 TYPE_LENGTH (type) = 0;
7828 return type;
7829}
7830
7831/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
7832 the value of type TYPE at VALADDR or ADDRESS (see comments at
7833 the beginning of this section) VAL according to GNAT conventions.
7834 DVAL0 should describe the (portion of a) record that contains any
df407dfe 7835 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
7836 an outer-level type (i.e., as opposed to a branch of a variant.) A
7837 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 7838 of the variant.
14f9c5c9 7839
4c4b4cd2
PH
7840 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7841 length are not statically known are discarded. As a consequence,
7842 VALADDR, ADDRESS and DVAL0 are ignored.
7843
7844 NOTE: Limitations: For now, we assume that dynamic fields and
7845 variants occupy whole numbers of bytes. However, they need not be
7846 byte-aligned. */
7847
7848struct type *
10a2c479 7849ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 7850 const gdb_byte *valaddr,
4c4b4cd2
PH
7851 CORE_ADDR address, struct value *dval0,
7852 int keep_dynamic_fields)
14f9c5c9 7853{
d2e4a39e
AS
7854 struct value *mark = value_mark ();
7855 struct value *dval;
7856 struct type *rtype;
14f9c5c9 7857 int nfields, bit_len;
4c4b4cd2 7858 int variant_field;
14f9c5c9 7859 long off;
d94e4f4f 7860 int fld_bit_len;
14f9c5c9
AS
7861 int f;
7862
4c4b4cd2
PH
7863 /* Compute the number of fields in this record type that are going
7864 to be processed: unless keep_dynamic_fields, this includes only
7865 fields whose position and length are static will be processed. */
7866 if (keep_dynamic_fields)
7867 nfields = TYPE_NFIELDS (type);
7868 else
7869 {
7870 nfields = 0;
76a01679 7871 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
7872 && !ada_is_variant_part (type, nfields)
7873 && !is_dynamic_field (type, nfields))
7874 nfields++;
7875 }
7876
e9bb382b 7877 rtype = alloc_type_copy (type);
14f9c5c9
AS
7878 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7879 INIT_CPLUS_SPECIFIC (rtype);
7880 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 7881 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
7882 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7883 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
7884 TYPE_NAME (rtype) = ada_type_name (type);
7885 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7886 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 7887
d2e4a39e
AS
7888 off = 0;
7889 bit_len = 0;
4c4b4cd2
PH
7890 variant_field = -1;
7891
14f9c5c9
AS
7892 for (f = 0; f < nfields; f += 1)
7893 {
6c038f32
PH
7894 off = align_value (off, field_alignment (type, f))
7895 + TYPE_FIELD_BITPOS (type, f);
945b3a32 7896 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 7897 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 7898
d2e4a39e 7899 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
7900 {
7901 variant_field = f;
d94e4f4f 7902 fld_bit_len = 0;
4c4b4cd2 7903 }
14f9c5c9 7904 else if (is_dynamic_field (type, f))
4c4b4cd2 7905 {
284614f0
JB
7906 const gdb_byte *field_valaddr = valaddr;
7907 CORE_ADDR field_address = address;
7908 struct type *field_type =
7909 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
7910
4c4b4cd2 7911 if (dval0 == NULL)
b5304971
JG
7912 {
7913 /* rtype's length is computed based on the run-time
7914 value of discriminants. If the discriminants are not
7915 initialized, the type size may be completely bogus and
0963b4bd 7916 GDB may fail to allocate a value for it. So check the
b5304971 7917 size first before creating the value. */
c1b5a1a6 7918 ada_ensure_varsize_limit (rtype);
012370f6
TT
7919 /* Using plain value_from_contents_and_address here
7920 causes problems because we will end up trying to
7921 resolve a type that is currently being
7922 constructed. */
7923 dval = value_from_contents_and_address_unresolved (rtype,
7924 valaddr,
7925 address);
9f1f738a 7926 rtype = value_type (dval);
b5304971 7927 }
4c4b4cd2
PH
7928 else
7929 dval = dval0;
7930
284614f0
JB
7931 /* If the type referenced by this field is an aligner type, we need
7932 to unwrap that aligner type, because its size might not be set.
7933 Keeping the aligner type would cause us to compute the wrong
7934 size for this field, impacting the offset of the all the fields
7935 that follow this one. */
7936 if (ada_is_aligner_type (field_type))
7937 {
7938 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
7939
7940 field_valaddr = cond_offset_host (field_valaddr, field_offset);
7941 field_address = cond_offset_target (field_address, field_offset);
7942 field_type = ada_aligned_type (field_type);
7943 }
7944
7945 field_valaddr = cond_offset_host (field_valaddr,
7946 off / TARGET_CHAR_BIT);
7947 field_address = cond_offset_target (field_address,
7948 off / TARGET_CHAR_BIT);
7949
7950 /* Get the fixed type of the field. Note that, in this case,
7951 we do not want to get the real type out of the tag: if
7952 the current field is the parent part of a tagged record,
7953 we will get the tag of the object. Clearly wrong: the real
7954 type of the parent is not the real type of the child. We
7955 would end up in an infinite loop. */
7956 field_type = ada_get_base_type (field_type);
7957 field_type = ada_to_fixed_type (field_type, field_valaddr,
7958 field_address, dval, 0);
27f2a97b
JB
7959 /* If the field size is already larger than the maximum
7960 object size, then the record itself will necessarily
7961 be larger than the maximum object size. We need to make
7962 this check now, because the size might be so ridiculously
7963 large (due to an uninitialized variable in the inferior)
7964 that it would cause an overflow when adding it to the
7965 record size. */
c1b5a1a6 7966 ada_ensure_varsize_limit (field_type);
284614f0
JB
7967
7968 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 7969 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
7970 /* The multiplication can potentially overflow. But because
7971 the field length has been size-checked just above, and
7972 assuming that the maximum size is a reasonable value,
7973 an overflow should not happen in practice. So rather than
7974 adding overflow recovery code to this already complex code,
7975 we just assume that it's not going to happen. */
d94e4f4f 7976 fld_bit_len =
4c4b4cd2
PH
7977 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
7978 }
14f9c5c9 7979 else
4c4b4cd2 7980 {
5ded5331
JB
7981 /* Note: If this field's type is a typedef, it is important
7982 to preserve the typedef layer.
7983
7984 Otherwise, we might be transforming a typedef to a fat
7985 pointer (encoding a pointer to an unconstrained array),
7986 into a basic fat pointer (encoding an unconstrained
7987 array). As both types are implemented using the same
7988 structure, the typedef is the only clue which allows us
7989 to distinguish between the two options. Stripping it
7990 would prevent us from printing this field appropriately. */
7991 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
7992 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7993 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 7994 fld_bit_len =
4c4b4cd2
PH
7995 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7996 else
5ded5331
JB
7997 {
7998 struct type *field_type = TYPE_FIELD_TYPE (type, f);
7999
8000 /* We need to be careful of typedefs when computing
8001 the length of our field. If this is a typedef,
8002 get the length of the target type, not the length
8003 of the typedef. */
8004 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8005 field_type = ada_typedef_target_type (field_type);
8006
8007 fld_bit_len =
8008 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8009 }
4c4b4cd2 8010 }
14f9c5c9 8011 if (off + fld_bit_len > bit_len)
4c4b4cd2 8012 bit_len = off + fld_bit_len;
d94e4f4f 8013 off += fld_bit_len;
4c4b4cd2
PH
8014 TYPE_LENGTH (rtype) =
8015 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 8016 }
4c4b4cd2
PH
8017
8018 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 8019 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
8020 the record. This can happen in the presence of representation
8021 clauses. */
8022 if (variant_field >= 0)
8023 {
8024 struct type *branch_type;
8025
8026 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8027
8028 if (dval0 == NULL)
9f1f738a 8029 {
012370f6
TT
8030 /* Using plain value_from_contents_and_address here causes
8031 problems because we will end up trying to resolve a type
8032 that is currently being constructed. */
8033 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8034 address);
9f1f738a
SA
8035 rtype = value_type (dval);
8036 }
4c4b4cd2
PH
8037 else
8038 dval = dval0;
8039
8040 branch_type =
8041 to_fixed_variant_branch_type
8042 (TYPE_FIELD_TYPE (type, variant_field),
8043 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8044 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8045 if (branch_type == NULL)
8046 {
8047 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8048 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8049 TYPE_NFIELDS (rtype) -= 1;
8050 }
8051 else
8052 {
8053 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8054 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8055 fld_bit_len =
8056 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8057 TARGET_CHAR_BIT;
8058 if (off + fld_bit_len > bit_len)
8059 bit_len = off + fld_bit_len;
8060 TYPE_LENGTH (rtype) =
8061 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8062 }
8063 }
8064
714e53ab
PH
8065 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8066 should contain the alignment of that record, which should be a strictly
8067 positive value. If null or negative, then something is wrong, most
8068 probably in the debug info. In that case, we don't round up the size
0963b4bd 8069 of the resulting type. If this record is not part of another structure,
714e53ab
PH
8070 the current RTYPE length might be good enough for our purposes. */
8071 if (TYPE_LENGTH (type) <= 0)
8072 {
323e0a4a
AC
8073 if (TYPE_NAME (rtype))
8074 warning (_("Invalid type size for `%s' detected: %d."),
8075 TYPE_NAME (rtype), TYPE_LENGTH (type));
8076 else
8077 warning (_("Invalid type size for <unnamed> detected: %d."),
8078 TYPE_LENGTH (type));
714e53ab
PH
8079 }
8080 else
8081 {
8082 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8083 TYPE_LENGTH (type));
8084 }
14f9c5c9
AS
8085
8086 value_free_to_mark (mark);
d2e4a39e 8087 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 8088 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8089 return rtype;
8090}
8091
4c4b4cd2
PH
8092/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8093 of 1. */
14f9c5c9 8094
d2e4a39e 8095static struct type *
fc1a4b47 8096template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
8097 CORE_ADDR address, struct value *dval0)
8098{
8099 return ada_template_to_fixed_record_type_1 (type, valaddr,
8100 address, dval0, 1);
8101}
8102
8103/* An ordinary record type in which ___XVL-convention fields and
8104 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8105 static approximations, containing all possible fields. Uses
8106 no runtime values. Useless for use in values, but that's OK,
8107 since the results are used only for type determinations. Works on both
8108 structs and unions. Representation note: to save space, we memorize
8109 the result of this function in the TYPE_TARGET_TYPE of the
8110 template type. */
8111
8112static struct type *
8113template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
8114{
8115 struct type *type;
8116 int nfields;
8117 int f;
8118
4c4b4cd2
PH
8119 if (TYPE_TARGET_TYPE (type0) != NULL)
8120 return TYPE_TARGET_TYPE (type0);
8121
8122 nfields = TYPE_NFIELDS (type0);
8123 type = type0;
14f9c5c9
AS
8124
8125 for (f = 0; f < nfields; f += 1)
8126 {
61ee279c 8127 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
4c4b4cd2 8128 struct type *new_type;
14f9c5c9 8129
4c4b4cd2
PH
8130 if (is_dynamic_field (type0, f))
8131 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
14f9c5c9 8132 else
f192137b 8133 new_type = static_unwrap_type (field_type);
4c4b4cd2
PH
8134 if (type == type0 && new_type != field_type)
8135 {
e9bb382b 8136 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
4c4b4cd2
PH
8137 TYPE_CODE (type) = TYPE_CODE (type0);
8138 INIT_CPLUS_SPECIFIC (type);
8139 TYPE_NFIELDS (type) = nfields;
8140 TYPE_FIELDS (type) = (struct field *)
8141 TYPE_ALLOC (type, nfields * sizeof (struct field));
8142 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8143 sizeof (struct field) * nfields);
8144 TYPE_NAME (type) = ada_type_name (type0);
8145 TYPE_TAG_NAME (type) = NULL;
876cecd0 8146 TYPE_FIXED_INSTANCE (type) = 1;
4c4b4cd2
PH
8147 TYPE_LENGTH (type) = 0;
8148 }
8149 TYPE_FIELD_TYPE (type, f) = new_type;
8150 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
14f9c5c9 8151 }
14f9c5c9
AS
8152 return type;
8153}
8154
4c4b4cd2 8155/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
8156 whose address in memory is ADDRESS, returns a revision of TYPE,
8157 which should be a non-dynamic-sized record, in which the variant
8158 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
8159 for discriminant values in DVAL0, which can be NULL if the record
8160 contains the necessary discriminant values. */
8161
d2e4a39e 8162static struct type *
fc1a4b47 8163to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 8164 CORE_ADDR address, struct value *dval0)
14f9c5c9 8165{
d2e4a39e 8166 struct value *mark = value_mark ();
4c4b4cd2 8167 struct value *dval;
d2e4a39e 8168 struct type *rtype;
14f9c5c9
AS
8169 struct type *branch_type;
8170 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 8171 int variant_field = variant_field_index (type);
14f9c5c9 8172
4c4b4cd2 8173 if (variant_field == -1)
14f9c5c9
AS
8174 return type;
8175
4c4b4cd2 8176 if (dval0 == NULL)
9f1f738a
SA
8177 {
8178 dval = value_from_contents_and_address (type, valaddr, address);
8179 type = value_type (dval);
8180 }
4c4b4cd2
PH
8181 else
8182 dval = dval0;
8183
e9bb382b 8184 rtype = alloc_type_copy (type);
14f9c5c9 8185 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
8186 INIT_CPLUS_SPECIFIC (rtype);
8187 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
8188 TYPE_FIELDS (rtype) =
8189 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8190 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 8191 sizeof (struct field) * nfields);
14f9c5c9
AS
8192 TYPE_NAME (rtype) = ada_type_name (type);
8193 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 8194 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
8195 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8196
4c4b4cd2
PH
8197 branch_type = to_fixed_variant_branch_type
8198 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 8199 cond_offset_host (valaddr,
4c4b4cd2
PH
8200 TYPE_FIELD_BITPOS (type, variant_field)
8201 / TARGET_CHAR_BIT),
d2e4a39e 8202 cond_offset_target (address,
4c4b4cd2
PH
8203 TYPE_FIELD_BITPOS (type, variant_field)
8204 / TARGET_CHAR_BIT), dval);
d2e4a39e 8205 if (branch_type == NULL)
14f9c5c9 8206 {
4c4b4cd2 8207 int f;
5b4ee69b 8208
4c4b4cd2
PH
8209 for (f = variant_field + 1; f < nfields; f += 1)
8210 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 8211 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
8212 }
8213 else
8214 {
4c4b4cd2
PH
8215 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8216 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8217 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 8218 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 8219 }
4c4b4cd2 8220 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 8221
4c4b4cd2 8222 value_free_to_mark (mark);
14f9c5c9
AS
8223 return rtype;
8224}
8225
8226/* An ordinary record type (with fixed-length fields) that describes
8227 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8228 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
8229 should be in DVAL, a record value; it may be NULL if the object
8230 at ADDR itself contains any necessary discriminant values.
8231 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8232 values from the record are needed. Except in the case that DVAL,
8233 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8234 unchecked) is replaced by a particular branch of the variant.
8235
8236 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8237 is questionable and may be removed. It can arise during the
8238 processing of an unconstrained-array-of-record type where all the
8239 variant branches have exactly the same size. This is because in
8240 such cases, the compiler does not bother to use the XVS convention
8241 when encoding the record. I am currently dubious of this
8242 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 8243
d2e4a39e 8244static struct type *
fc1a4b47 8245to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 8246 CORE_ADDR address, struct value *dval)
14f9c5c9 8247{
d2e4a39e 8248 struct type *templ_type;
14f9c5c9 8249
876cecd0 8250 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8251 return type0;
8252
d2e4a39e 8253 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
8254
8255 if (templ_type != NULL)
8256 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
8257 else if (variant_field_index (type0) >= 0)
8258 {
8259 if (dval == NULL && valaddr == NULL && address == 0)
8260 return type0;
8261 return to_record_with_fixed_variant_part (type0, valaddr, address,
8262 dval);
8263 }
14f9c5c9
AS
8264 else
8265 {
876cecd0 8266 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
8267 return type0;
8268 }
8269
8270}
8271
8272/* An ordinary record type (with fixed-length fields) that describes
8273 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8274 union type. Any necessary discriminants' values should be in DVAL,
8275 a record value. That is, this routine selects the appropriate
8276 branch of the union at ADDR according to the discriminant value
b1f33ddd 8277 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8278 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8279
d2e4a39e 8280static struct type *
fc1a4b47 8281to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8282 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8283{
8284 int which;
d2e4a39e
AS
8285 struct type *templ_type;
8286 struct type *var_type;
14f9c5c9
AS
8287
8288 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8289 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8290 else
14f9c5c9
AS
8291 var_type = var_type0;
8292
8293 templ_type = ada_find_parallel_type (var_type, "___XVU");
8294
8295 if (templ_type != NULL)
8296 var_type = templ_type;
8297
b1f33ddd
JB
8298 if (is_unchecked_variant (var_type, value_type (dval)))
8299 return var_type0;
d2e4a39e
AS
8300 which =
8301 ada_which_variant_applies (var_type,
0fd88904 8302 value_type (dval), value_contents (dval));
14f9c5c9
AS
8303
8304 if (which < 0)
e9bb382b 8305 return empty_record (var_type);
14f9c5c9 8306 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8307 return to_fixed_record_type
d2e4a39e
AS
8308 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8309 valaddr, address, dval);
4c4b4cd2 8310 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8311 return
8312 to_fixed_record_type
8313 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8314 else
8315 return TYPE_FIELD_TYPE (var_type, which);
8316}
8317
8908fca5
JB
8318/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8319 ENCODING_TYPE, a type following the GNAT conventions for discrete
8320 type encodings, only carries redundant information. */
8321
8322static int
8323ada_is_redundant_range_encoding (struct type *range_type,
8324 struct type *encoding_type)
8325{
8326 struct type *fixed_range_type;
8327 char *bounds_str;
8328 int n;
8329 LONGEST lo, hi;
8330
8331 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8332
005e2509
JB
8333 if (TYPE_CODE (get_base_type (range_type))
8334 != TYPE_CODE (get_base_type (encoding_type)))
8335 {
8336 /* The compiler probably used a simple base type to describe
8337 the range type instead of the range's actual base type,
8338 expecting us to get the real base type from the encoding
8339 anyway. In this situation, the encoding cannot be ignored
8340 as redundant. */
8341 return 0;
8342 }
8343
8908fca5
JB
8344 if (is_dynamic_type (range_type))
8345 return 0;
8346
8347 if (TYPE_NAME (encoding_type) == NULL)
8348 return 0;
8349
8350 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8351 if (bounds_str == NULL)
8352 return 0;
8353
8354 n = 8; /* Skip "___XDLU_". */
8355 if (!ada_scan_number (bounds_str, n, &lo, &n))
8356 return 0;
8357 if (TYPE_LOW_BOUND (range_type) != lo)
8358 return 0;
8359
8360 n += 2; /* Skip the "__" separator between the two bounds. */
8361 if (!ada_scan_number (bounds_str, n, &hi, &n))
8362 return 0;
8363 if (TYPE_HIGH_BOUND (range_type) != hi)
8364 return 0;
8365
8366 return 1;
8367}
8368
8369/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8370 a type following the GNAT encoding for describing array type
8371 indices, only carries redundant information. */
8372
8373static int
8374ada_is_redundant_index_type_desc (struct type *array_type,
8375 struct type *desc_type)
8376{
8377 struct type *this_layer = check_typedef (array_type);
8378 int i;
8379
8380 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8381 {
8382 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8383 TYPE_FIELD_TYPE (desc_type, i)))
8384 return 0;
8385 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8386 }
8387
8388 return 1;
8389}
8390
14f9c5c9
AS
8391/* Assuming that TYPE0 is an array type describing the type of a value
8392 at ADDR, and that DVAL describes a record containing any
8393 discriminants used in TYPE0, returns a type for the value that
8394 contains no dynamic components (that is, no components whose sizes
8395 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8396 true, gives an error message if the resulting type's size is over
4c4b4cd2 8397 varsize_limit. */
14f9c5c9 8398
d2e4a39e
AS
8399static struct type *
8400to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8401 int ignore_too_big)
14f9c5c9 8402{
d2e4a39e
AS
8403 struct type *index_type_desc;
8404 struct type *result;
ad82864c 8405 int constrained_packed_array_p;
14f9c5c9 8406
b0dd7688 8407 type0 = ada_check_typedef (type0);
284614f0 8408 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8409 return type0;
14f9c5c9 8410
ad82864c
JB
8411 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8412 if (constrained_packed_array_p)
8413 type0 = decode_constrained_packed_array_type (type0);
284614f0 8414
14f9c5c9 8415 index_type_desc = ada_find_parallel_type (type0, "___XA");
28c85d6c 8416 ada_fixup_array_indexes_type (index_type_desc);
8908fca5
JB
8417 if (index_type_desc != NULL
8418 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8419 {
8420 /* Ignore this ___XA parallel type, as it does not bring any
8421 useful information. This allows us to avoid creating fixed
8422 versions of the array's index types, which would be identical
8423 to the original ones. This, in turn, can also help avoid
8424 the creation of fixed versions of the array itself. */
8425 index_type_desc = NULL;
8426 }
8427
14f9c5c9
AS
8428 if (index_type_desc == NULL)
8429 {
61ee279c 8430 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8431
14f9c5c9 8432 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8433 depend on the contents of the array in properly constructed
8434 debugging data. */
529cad9c
PH
8435 /* Create a fixed version of the array element type.
8436 We're not providing the address of an element here,
e1d5a0d2 8437 and thus the actual object value cannot be inspected to do
529cad9c
PH
8438 the conversion. This should not be a problem, since arrays of
8439 unconstrained objects are not allowed. In particular, all
8440 the elements of an array of a tagged type should all be of
8441 the same type specified in the debugging info. No need to
8442 consult the object tag. */
1ed6ede0 8443 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8444
284614f0
JB
8445 /* Make sure we always create a new array type when dealing with
8446 packed array types, since we're going to fix-up the array
8447 type length and element bitsize a little further down. */
ad82864c 8448 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8449 result = type0;
14f9c5c9 8450 else
e9bb382b 8451 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8452 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8453 }
8454 else
8455 {
8456 int i;
8457 struct type *elt_type0;
8458
8459 elt_type0 = type0;
8460 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8461 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8462
8463 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8464 depend on the contents of the array in properly constructed
8465 debugging data. */
529cad9c
PH
8466 /* Create a fixed version of the array element type.
8467 We're not providing the address of an element here,
e1d5a0d2 8468 and thus the actual object value cannot be inspected to do
529cad9c
PH
8469 the conversion. This should not be a problem, since arrays of
8470 unconstrained objects are not allowed. In particular, all
8471 the elements of an array of a tagged type should all be of
8472 the same type specified in the debugging info. No need to
8473 consult the object tag. */
1ed6ede0
JB
8474 result =
8475 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8476
8477 elt_type0 = type0;
14f9c5c9 8478 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8479 {
8480 struct type *range_type =
28c85d6c 8481 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8482
e9bb382b 8483 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8484 result, range_type);
1ce677a4 8485 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8486 }
d2e4a39e 8487 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8488 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8489 }
8490
2e6fda7d
JB
8491 /* We want to preserve the type name. This can be useful when
8492 trying to get the type name of a value that has already been
8493 printed (for instance, if the user did "print VAR; whatis $". */
8494 TYPE_NAME (result) = TYPE_NAME (type0);
8495
ad82864c 8496 if (constrained_packed_array_p)
284614f0
JB
8497 {
8498 /* So far, the resulting type has been created as if the original
8499 type was a regular (non-packed) array type. As a result, the
8500 bitsize of the array elements needs to be set again, and the array
8501 length needs to be recomputed based on that bitsize. */
8502 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8503 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8504
8505 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8506 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8507 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8508 TYPE_LENGTH (result)++;
8509 }
8510
876cecd0 8511 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8512 return result;
d2e4a39e 8513}
14f9c5c9
AS
8514
8515
8516/* A standard type (containing no dynamically sized components)
8517 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8518 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8519 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8520 ADDRESS or in VALADDR contains these discriminants.
8521
1ed6ede0
JB
8522 If CHECK_TAG is not null, in the case of tagged types, this function
8523 attempts to locate the object's tag and use it to compute the actual
8524 type. However, when ADDRESS is null, we cannot use it to determine the
8525 location of the tag, and therefore compute the tagged type's actual type.
8526 So we return the tagged type without consulting the tag. */
529cad9c 8527
f192137b
JB
8528static struct type *
8529ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 8530 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 8531{
61ee279c 8532 type = ada_check_typedef (type);
d2e4a39e
AS
8533 switch (TYPE_CODE (type))
8534 {
8535 default:
14f9c5c9 8536 return type;
d2e4a39e 8537 case TYPE_CODE_STRUCT:
4c4b4cd2 8538 {
76a01679 8539 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
8540 struct type *fixed_record_type =
8541 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 8542
529cad9c
PH
8543 /* If STATIC_TYPE is a tagged type and we know the object's address,
8544 then we can determine its tag, and compute the object's actual
0963b4bd 8545 type from there. Note that we have to use the fixed record
1ed6ede0
JB
8546 type (the parent part of the record may have dynamic fields
8547 and the way the location of _tag is expressed may depend on
8548 them). */
529cad9c 8549
1ed6ede0 8550 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 8551 {
b50d69b5
JG
8552 struct value *tag =
8553 value_tag_from_contents_and_address
8554 (fixed_record_type,
8555 valaddr,
8556 address);
8557 struct type *real_type = type_from_tag (tag);
8558 struct value *obj =
8559 value_from_contents_and_address (fixed_record_type,
8560 valaddr,
8561 address);
9f1f738a 8562 fixed_record_type = value_type (obj);
76a01679 8563 if (real_type != NULL)
b50d69b5
JG
8564 return to_fixed_record_type
8565 (real_type, NULL,
8566 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 8567 }
4af88198
JB
8568
8569 /* Check to see if there is a parallel ___XVZ variable.
8570 If there is, then it provides the actual size of our type. */
8571 else if (ada_type_name (fixed_record_type) != NULL)
8572 {
0d5cff50 8573 const char *name = ada_type_name (fixed_record_type);
4af88198
JB
8574 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
8575 int xvz_found = 0;
8576 LONGEST size;
8577
88c15c34 8578 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
4af88198
JB
8579 size = get_int_var_value (xvz_name, &xvz_found);
8580 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8581 {
8582 fixed_record_type = copy_type (fixed_record_type);
8583 TYPE_LENGTH (fixed_record_type) = size;
8584
8585 /* The FIXED_RECORD_TYPE may have be a stub. We have
8586 observed this when the debugging info is STABS, and
8587 apparently it is something that is hard to fix.
8588
8589 In practice, we don't need the actual type definition
8590 at all, because the presence of the XVZ variable allows us
8591 to assume that there must be a XVS type as well, which we
8592 should be able to use later, when we need the actual type
8593 definition.
8594
8595 In the meantime, pretend that the "fixed" type we are
8596 returning is NOT a stub, because this can cause trouble
8597 when using this type to create new types targeting it.
8598 Indeed, the associated creation routines often check
8599 whether the target type is a stub and will try to replace
0963b4bd 8600 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
8601 might cause the new type to have the wrong size too.
8602 Consider the case of an array, for instance, where the size
8603 of the array is computed from the number of elements in
8604 our array multiplied by the size of its element. */
8605 TYPE_STUB (fixed_record_type) = 0;
8606 }
8607 }
1ed6ede0 8608 return fixed_record_type;
4c4b4cd2 8609 }
d2e4a39e 8610 case TYPE_CODE_ARRAY:
4c4b4cd2 8611 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
8612 case TYPE_CODE_UNION:
8613 if (dval == NULL)
4c4b4cd2 8614 return type;
d2e4a39e 8615 else
4c4b4cd2 8616 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 8617 }
14f9c5c9
AS
8618}
8619
f192137b
JB
8620/* The same as ada_to_fixed_type_1, except that it preserves the type
8621 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
8622
8623 The typedef layer needs be preserved in order to differentiate between
8624 arrays and array pointers when both types are implemented using the same
8625 fat pointer. In the array pointer case, the pointer is encoded as
8626 a typedef of the pointer type. For instance, considering:
8627
8628 type String_Access is access String;
8629 S1 : String_Access := null;
8630
8631 To the debugger, S1 is defined as a typedef of type String. But
8632 to the user, it is a pointer. So if the user tries to print S1,
8633 we should not dereference the array, but print the array address
8634 instead.
8635
8636 If we didn't preserve the typedef layer, we would lose the fact that
8637 the type is to be presented as a pointer (needs de-reference before
8638 being printed). And we would also use the source-level type name. */
f192137b
JB
8639
8640struct type *
8641ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8642 CORE_ADDR address, struct value *dval, int check_tag)
8643
8644{
8645 struct type *fixed_type =
8646 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8647
96dbd2c1
JB
8648 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8649 then preserve the typedef layer.
8650
8651 Implementation note: We can only check the main-type portion of
8652 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8653 from TYPE now returns a type that has the same instance flags
8654 as TYPE. For instance, if TYPE is a "typedef const", and its
8655 target type is a "struct", then the typedef elimination will return
8656 a "const" version of the target type. See check_typedef for more
8657 details about how the typedef layer elimination is done.
8658
8659 brobecker/2010-11-19: It seems to me that the only case where it is
8660 useful to preserve the typedef layer is when dealing with fat pointers.
8661 Perhaps, we could add a check for that and preserve the typedef layer
8662 only in that situation. But this seems unecessary so far, probably
8663 because we call check_typedef/ada_check_typedef pretty much everywhere.
8664 */
f192137b 8665 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 8666 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 8667 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
8668 return type;
8669
8670 return fixed_type;
8671}
8672
14f9c5c9 8673/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 8674 TYPE0, but based on no runtime data. */
14f9c5c9 8675
d2e4a39e
AS
8676static struct type *
8677to_static_fixed_type (struct type *type0)
14f9c5c9 8678{
d2e4a39e 8679 struct type *type;
14f9c5c9
AS
8680
8681 if (type0 == NULL)
8682 return NULL;
8683
876cecd0 8684 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8685 return type0;
8686
61ee279c 8687 type0 = ada_check_typedef (type0);
d2e4a39e 8688
14f9c5c9
AS
8689 switch (TYPE_CODE (type0))
8690 {
8691 default:
8692 return type0;
8693 case TYPE_CODE_STRUCT:
8694 type = dynamic_template_type (type0);
d2e4a39e 8695 if (type != NULL)
4c4b4cd2
PH
8696 return template_to_static_fixed_type (type);
8697 else
8698 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8699 case TYPE_CODE_UNION:
8700 type = ada_find_parallel_type (type0, "___XVU");
8701 if (type != NULL)
4c4b4cd2
PH
8702 return template_to_static_fixed_type (type);
8703 else
8704 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8705 }
8706}
8707
4c4b4cd2
PH
8708/* A static approximation of TYPE with all type wrappers removed. */
8709
d2e4a39e
AS
8710static struct type *
8711static_unwrap_type (struct type *type)
14f9c5c9
AS
8712{
8713 if (ada_is_aligner_type (type))
8714 {
61ee279c 8715 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 8716 if (ada_type_name (type1) == NULL)
4c4b4cd2 8717 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
8718
8719 return static_unwrap_type (type1);
8720 }
d2e4a39e 8721 else
14f9c5c9 8722 {
d2e4a39e 8723 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 8724
d2e4a39e 8725 if (raw_real_type == type)
4c4b4cd2 8726 return type;
14f9c5c9 8727 else
4c4b4cd2 8728 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
8729 }
8730}
8731
8732/* In some cases, incomplete and private types require
4c4b4cd2 8733 cross-references that are not resolved as records (for example,
14f9c5c9
AS
8734 type Foo;
8735 type FooP is access Foo;
8736 V: FooP;
8737 type Foo is array ...;
4c4b4cd2 8738 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
8739 cross-references to such types, we instead substitute for FooP a
8740 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 8741 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
8742
8743/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
8744 exists, otherwise TYPE. */
8745
d2e4a39e 8746struct type *
61ee279c 8747ada_check_typedef (struct type *type)
14f9c5c9 8748{
727e3d2e
JB
8749 if (type == NULL)
8750 return NULL;
8751
720d1a40
JB
8752 /* If our type is a typedef type of a fat pointer, then we're done.
8753 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8754 what allows us to distinguish between fat pointers that represent
8755 array types, and fat pointers that represent array access types
8756 (in both cases, the compiler implements them as fat pointers). */
8757 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8758 && is_thick_pntr (ada_typedef_target_type (type)))
8759 return type;
8760
14f9c5c9
AS
8761 CHECK_TYPEDEF (type);
8762 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 8763 || !TYPE_STUB (type)
14f9c5c9
AS
8764 || TYPE_TAG_NAME (type) == NULL)
8765 return type;
d2e4a39e 8766 else
14f9c5c9 8767 {
0d5cff50 8768 const char *name = TYPE_TAG_NAME (type);
d2e4a39e 8769 struct type *type1 = ada_find_any_type (name);
5b4ee69b 8770
05e522ef
JB
8771 if (type1 == NULL)
8772 return type;
8773
8774 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8775 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
8776 types, only for the typedef-to-array types). If that's the case,
8777 strip the typedef layer. */
8778 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
8779 type1 = ada_check_typedef (type1);
8780
8781 return type1;
14f9c5c9
AS
8782 }
8783}
8784
8785/* A value representing the data at VALADDR/ADDRESS as described by
8786 type TYPE0, but with a standard (static-sized) type that correctly
8787 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8788 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 8789 creation of struct values]. */
14f9c5c9 8790
4c4b4cd2
PH
8791static struct value *
8792ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8793 struct value *val0)
14f9c5c9 8794{
1ed6ede0 8795 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 8796
14f9c5c9
AS
8797 if (type == type0 && val0 != NULL)
8798 return val0;
d2e4a39e 8799 else
4c4b4cd2
PH
8800 return value_from_contents_and_address (type, 0, address);
8801}
8802
8803/* A value representing VAL, but with a standard (static-sized) type
8804 that correctly describes it. Does not necessarily create a new
8805 value. */
8806
0c3acc09 8807struct value *
4c4b4cd2
PH
8808ada_to_fixed_value (struct value *val)
8809{
c48db5ca
JB
8810 val = unwrap_value (val);
8811 val = ada_to_fixed_value_create (value_type (val),
8812 value_address (val),
8813 val);
8814 return val;
14f9c5c9 8815}
d2e4a39e 8816\f
14f9c5c9 8817
14f9c5c9
AS
8818/* Attributes */
8819
4c4b4cd2
PH
8820/* Table mapping attribute numbers to names.
8821 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 8822
d2e4a39e 8823static const char *attribute_names[] = {
14f9c5c9
AS
8824 "<?>",
8825
d2e4a39e 8826 "first",
14f9c5c9
AS
8827 "last",
8828 "length",
8829 "image",
14f9c5c9
AS
8830 "max",
8831 "min",
4c4b4cd2
PH
8832 "modulus",
8833 "pos",
8834 "size",
8835 "tag",
14f9c5c9 8836 "val",
14f9c5c9
AS
8837 0
8838};
8839
d2e4a39e 8840const char *
4c4b4cd2 8841ada_attribute_name (enum exp_opcode n)
14f9c5c9 8842{
4c4b4cd2
PH
8843 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8844 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
8845 else
8846 return attribute_names[0];
8847}
8848
4c4b4cd2 8849/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 8850
4c4b4cd2
PH
8851static LONGEST
8852pos_atr (struct value *arg)
14f9c5c9 8853{
24209737
PH
8854 struct value *val = coerce_ref (arg);
8855 struct type *type = value_type (val);
14f9c5c9 8856
d2e4a39e 8857 if (!discrete_type_p (type))
323e0a4a 8858 error (_("'POS only defined on discrete types"));
14f9c5c9
AS
8859
8860 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8861 {
8862 int i;
24209737 8863 LONGEST v = value_as_long (val);
14f9c5c9 8864
d2e4a39e 8865 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2 8866 {
14e75d8e 8867 if (v == TYPE_FIELD_ENUMVAL (type, i))
4c4b4cd2
PH
8868 return i;
8869 }
323e0a4a 8870 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9
AS
8871 }
8872 else
24209737 8873 return value_as_long (val);
4c4b4cd2
PH
8874}
8875
8876static struct value *
3cb382c9 8877value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 8878{
3cb382c9 8879 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
8880}
8881
4c4b4cd2 8882/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 8883
d2e4a39e
AS
8884static struct value *
8885value_val_atr (struct type *type, struct value *arg)
14f9c5c9 8886{
d2e4a39e 8887 if (!discrete_type_p (type))
323e0a4a 8888 error (_("'VAL only defined on discrete types"));
df407dfe 8889 if (!integer_type_p (value_type (arg)))
323e0a4a 8890 error (_("'VAL requires integral argument"));
14f9c5c9
AS
8891
8892 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8893 {
8894 long pos = value_as_long (arg);
5b4ee69b 8895
14f9c5c9 8896 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 8897 error (_("argument to 'VAL out of range"));
14e75d8e 8898 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
8899 }
8900 else
8901 return value_from_longest (type, value_as_long (arg));
8902}
14f9c5c9 8903\f
d2e4a39e 8904
4c4b4cd2 8905 /* Evaluation */
14f9c5c9 8906
4c4b4cd2
PH
8907/* True if TYPE appears to be an Ada character type.
8908 [At the moment, this is true only for Character and Wide_Character;
8909 It is a heuristic test that could stand improvement]. */
14f9c5c9 8910
d2e4a39e
AS
8911int
8912ada_is_character_type (struct type *type)
14f9c5c9 8913{
7b9f71f2
JB
8914 const char *name;
8915
8916 /* If the type code says it's a character, then assume it really is,
8917 and don't check any further. */
8918 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
8919 return 1;
8920
8921 /* Otherwise, assume it's a character type iff it is a discrete type
8922 with a known character type name. */
8923 name = ada_type_name (type);
8924 return (name != NULL
8925 && (TYPE_CODE (type) == TYPE_CODE_INT
8926 || TYPE_CODE (type) == TYPE_CODE_RANGE)
8927 && (strcmp (name, "character") == 0
8928 || strcmp (name, "wide_character") == 0
5a517ebd 8929 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 8930 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
8931}
8932
4c4b4cd2 8933/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
8934
8935int
ebf56fd3 8936ada_is_string_type (struct type *type)
14f9c5c9 8937{
61ee279c 8938 type = ada_check_typedef (type);
d2e4a39e 8939 if (type != NULL
14f9c5c9 8940 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
8941 && (ada_is_simple_array_type (type)
8942 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
8943 && ada_array_arity (type) == 1)
8944 {
8945 struct type *elttype = ada_array_element_type (type, 1);
8946
8947 return ada_is_character_type (elttype);
8948 }
d2e4a39e 8949 else
14f9c5c9
AS
8950 return 0;
8951}
8952
5bf03f13
JB
8953/* The compiler sometimes provides a parallel XVS type for a given
8954 PAD type. Normally, it is safe to follow the PAD type directly,
8955 but older versions of the compiler have a bug that causes the offset
8956 of its "F" field to be wrong. Following that field in that case
8957 would lead to incorrect results, but this can be worked around
8958 by ignoring the PAD type and using the associated XVS type instead.
8959
8960 Set to True if the debugger should trust the contents of PAD types.
8961 Otherwise, ignore the PAD type if there is a parallel XVS type. */
8962static int trust_pad_over_xvs = 1;
14f9c5c9
AS
8963
8964/* True if TYPE is a struct type introduced by the compiler to force the
8965 alignment of a value. Such types have a single field with a
4c4b4cd2 8966 distinctive name. */
14f9c5c9
AS
8967
8968int
ebf56fd3 8969ada_is_aligner_type (struct type *type)
14f9c5c9 8970{
61ee279c 8971 type = ada_check_typedef (type);
714e53ab 8972
5bf03f13 8973 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
8974 return 0;
8975
14f9c5c9 8976 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
8977 && TYPE_NFIELDS (type) == 1
8978 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
8979}
8980
8981/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 8982 the parallel type. */
14f9c5c9 8983
d2e4a39e
AS
8984struct type *
8985ada_get_base_type (struct type *raw_type)
14f9c5c9 8986{
d2e4a39e
AS
8987 struct type *real_type_namer;
8988 struct type *raw_real_type;
14f9c5c9
AS
8989
8990 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
8991 return raw_type;
8992
284614f0
JB
8993 if (ada_is_aligner_type (raw_type))
8994 /* The encoding specifies that we should always use the aligner type.
8995 So, even if this aligner type has an associated XVS type, we should
8996 simply ignore it.
8997
8998 According to the compiler gurus, an XVS type parallel to an aligner
8999 type may exist because of a stabs limitation. In stabs, aligner
9000 types are empty because the field has a variable-sized type, and
9001 thus cannot actually be used as an aligner type. As a result,
9002 we need the associated parallel XVS type to decode the type.
9003 Since the policy in the compiler is to not change the internal
9004 representation based on the debugging info format, we sometimes
9005 end up having a redundant XVS type parallel to the aligner type. */
9006 return raw_type;
9007
14f9c5c9 9008 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 9009 if (real_type_namer == NULL
14f9c5c9
AS
9010 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9011 || TYPE_NFIELDS (real_type_namer) != 1)
9012 return raw_type;
9013
f80d3ff2
JB
9014 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9015 {
9016 /* This is an older encoding form where the base type needs to be
9017 looked up by name. We prefer the newer enconding because it is
9018 more efficient. */
9019 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9020 if (raw_real_type == NULL)
9021 return raw_type;
9022 else
9023 return raw_real_type;
9024 }
9025
9026 /* The field in our XVS type is a reference to the base type. */
9027 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 9028}
14f9c5c9 9029
4c4b4cd2 9030/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 9031
d2e4a39e
AS
9032struct type *
9033ada_aligned_type (struct type *type)
14f9c5c9
AS
9034{
9035 if (ada_is_aligner_type (type))
9036 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9037 else
9038 return ada_get_base_type (type);
9039}
9040
9041
9042/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 9043 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 9044
fc1a4b47
AC
9045const gdb_byte *
9046ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 9047{
d2e4a39e 9048 if (ada_is_aligner_type (type))
14f9c5c9 9049 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
9050 valaddr +
9051 TYPE_FIELD_BITPOS (type,
9052 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
9053 else
9054 return valaddr;
9055}
9056
4c4b4cd2
PH
9057
9058
14f9c5c9 9059/* The printed representation of an enumeration literal with encoded
4c4b4cd2 9060 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
9061const char *
9062ada_enum_name (const char *name)
14f9c5c9 9063{
4c4b4cd2
PH
9064 static char *result;
9065 static size_t result_len = 0;
d2e4a39e 9066 char *tmp;
14f9c5c9 9067
4c4b4cd2
PH
9068 /* First, unqualify the enumeration name:
9069 1. Search for the last '.' character. If we find one, then skip
177b42fe 9070 all the preceding characters, the unqualified name starts
76a01679 9071 right after that dot.
4c4b4cd2 9072 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
9073 translates dots into "__". Search forward for double underscores,
9074 but stop searching when we hit an overloading suffix, which is
9075 of the form "__" followed by digits. */
4c4b4cd2 9076
c3e5cd34
PH
9077 tmp = strrchr (name, '.');
9078 if (tmp != NULL)
4c4b4cd2
PH
9079 name = tmp + 1;
9080 else
14f9c5c9 9081 {
4c4b4cd2
PH
9082 while ((tmp = strstr (name, "__")) != NULL)
9083 {
9084 if (isdigit (tmp[2]))
9085 break;
9086 else
9087 name = tmp + 2;
9088 }
14f9c5c9
AS
9089 }
9090
9091 if (name[0] == 'Q')
9092 {
14f9c5c9 9093 int v;
5b4ee69b 9094
14f9c5c9 9095 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
9096 {
9097 if (sscanf (name + 2, "%x", &v) != 1)
9098 return name;
9099 }
14f9c5c9 9100 else
4c4b4cd2 9101 return name;
14f9c5c9 9102
4c4b4cd2 9103 GROW_VECT (result, result_len, 16);
14f9c5c9 9104 if (isascii (v) && isprint (v))
88c15c34 9105 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 9106 else if (name[1] == 'U')
88c15c34 9107 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 9108 else
88c15c34 9109 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
9110
9111 return result;
9112 }
d2e4a39e 9113 else
4c4b4cd2 9114 {
c3e5cd34
PH
9115 tmp = strstr (name, "__");
9116 if (tmp == NULL)
9117 tmp = strstr (name, "$");
9118 if (tmp != NULL)
4c4b4cd2
PH
9119 {
9120 GROW_VECT (result, result_len, tmp - name + 1);
9121 strncpy (result, name, tmp - name);
9122 result[tmp - name] = '\0';
9123 return result;
9124 }
9125
9126 return name;
9127 }
14f9c5c9
AS
9128}
9129
14f9c5c9
AS
9130/* Evaluate the subexpression of EXP starting at *POS as for
9131 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 9132 expression. */
14f9c5c9 9133
d2e4a39e
AS
9134static struct value *
9135evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 9136{
4b27a620 9137 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
9138}
9139
9140/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 9141 value it wraps. */
14f9c5c9 9142
d2e4a39e
AS
9143static struct value *
9144unwrap_value (struct value *val)
14f9c5c9 9145{
df407dfe 9146 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 9147
14f9c5c9
AS
9148 if (ada_is_aligner_type (type))
9149 {
de4d072f 9150 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 9151 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 9152
14f9c5c9 9153 if (ada_type_name (val_type) == NULL)
4c4b4cd2 9154 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
9155
9156 return unwrap_value (v);
9157 }
d2e4a39e 9158 else
14f9c5c9 9159 {
d2e4a39e 9160 struct type *raw_real_type =
61ee279c 9161 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 9162
5bf03f13
JB
9163 /* If there is no parallel XVS or XVE type, then the value is
9164 already unwrapped. Return it without further modification. */
9165 if ((type == raw_real_type)
9166 && ada_find_parallel_type (type, "___XVE") == NULL)
9167 return val;
14f9c5c9 9168
d2e4a39e 9169 return
4c4b4cd2
PH
9170 coerce_unspec_val_to_type
9171 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 9172 value_address (val),
1ed6ede0 9173 NULL, 1));
14f9c5c9
AS
9174 }
9175}
d2e4a39e
AS
9176
9177static struct value *
9178cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
9179{
9180 LONGEST val;
9181
df407dfe 9182 if (type == value_type (arg))
14f9c5c9 9183 return arg;
df407dfe 9184 else if (ada_is_fixed_point_type (value_type (arg)))
d2e4a39e 9185 val = ada_float_to_fixed (type,
df407dfe 9186 ada_fixed_to_float (value_type (arg),
4c4b4cd2 9187 value_as_long (arg)));
d2e4a39e 9188 else
14f9c5c9 9189 {
a53b7a21 9190 DOUBLEST argd = value_as_double (arg);
5b4ee69b 9191
14f9c5c9
AS
9192 val = ada_float_to_fixed (type, argd);
9193 }
9194
9195 return value_from_longest (type, val);
9196}
9197
d2e4a39e 9198static struct value *
a53b7a21 9199cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 9200{
df407dfe 9201 DOUBLEST val = ada_fixed_to_float (value_type (arg),
4c4b4cd2 9202 value_as_long (arg));
5b4ee69b 9203
a53b7a21 9204 return value_from_double (type, val);
14f9c5c9
AS
9205}
9206
d99dcf51
JB
9207/* Given two array types T1 and T2, return nonzero iff both arrays
9208 contain the same number of elements. */
9209
9210static int
9211ada_same_array_size_p (struct type *t1, struct type *t2)
9212{
9213 LONGEST lo1, hi1, lo2, hi2;
9214
9215 /* Get the array bounds in order to verify that the size of
9216 the two arrays match. */
9217 if (!get_array_bounds (t1, &lo1, &hi1)
9218 || !get_array_bounds (t2, &lo2, &hi2))
9219 error (_("unable to determine array bounds"));
9220
9221 /* To make things easier for size comparison, normalize a bit
9222 the case of empty arrays by making sure that the difference
9223 between upper bound and lower bound is always -1. */
9224 if (lo1 > hi1)
9225 hi1 = lo1 - 1;
9226 if (lo2 > hi2)
9227 hi2 = lo2 - 1;
9228
9229 return (hi1 - lo1 == hi2 - lo2);
9230}
9231
9232/* Assuming that VAL is an array of integrals, and TYPE represents
9233 an array with the same number of elements, but with wider integral
9234 elements, return an array "casted" to TYPE. In practice, this
9235 means that the returned array is built by casting each element
9236 of the original array into TYPE's (wider) element type. */
9237
9238static struct value *
9239ada_promote_array_of_integrals (struct type *type, struct value *val)
9240{
9241 struct type *elt_type = TYPE_TARGET_TYPE (type);
9242 LONGEST lo, hi;
9243 struct value *res;
9244 LONGEST i;
9245
9246 /* Verify that both val and type are arrays of scalars, and
9247 that the size of val's elements is smaller than the size
9248 of type's element. */
9249 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9250 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9251 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9252 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9253 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9254 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9255
9256 if (!get_array_bounds (type, &lo, &hi))
9257 error (_("unable to determine array bounds"));
9258
9259 res = allocate_value (type);
9260
9261 /* Promote each array element. */
9262 for (i = 0; i < hi - lo + 1; i++)
9263 {
9264 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9265
9266 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9267 value_contents_all (elt), TYPE_LENGTH (elt_type));
9268 }
9269
9270 return res;
9271}
9272
4c4b4cd2
PH
9273/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9274 return the converted value. */
9275
d2e4a39e
AS
9276static struct value *
9277coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 9278{
df407dfe 9279 struct type *type2 = value_type (val);
5b4ee69b 9280
14f9c5c9
AS
9281 if (type == type2)
9282 return val;
9283
61ee279c
PH
9284 type2 = ada_check_typedef (type2);
9285 type = ada_check_typedef (type);
14f9c5c9 9286
d2e4a39e
AS
9287 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9288 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
9289 {
9290 val = ada_value_ind (val);
df407dfe 9291 type2 = value_type (val);
14f9c5c9
AS
9292 }
9293
d2e4a39e 9294 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
9295 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9296 {
d99dcf51
JB
9297 if (!ada_same_array_size_p (type, type2))
9298 error (_("cannot assign arrays of different length"));
9299
9300 if (is_integral_type (TYPE_TARGET_TYPE (type))
9301 && is_integral_type (TYPE_TARGET_TYPE (type2))
9302 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9303 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9304 {
9305 /* Allow implicit promotion of the array elements to
9306 a wider type. */
9307 return ada_promote_array_of_integrals (type, val);
9308 }
9309
9310 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9311 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 9312 error (_("Incompatible types in assignment"));
04624583 9313 deprecated_set_value_type (val, type);
14f9c5c9 9314 }
d2e4a39e 9315 return val;
14f9c5c9
AS
9316}
9317
4c4b4cd2
PH
9318static struct value *
9319ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9320{
9321 struct value *val;
9322 struct type *type1, *type2;
9323 LONGEST v, v1, v2;
9324
994b9211
AC
9325 arg1 = coerce_ref (arg1);
9326 arg2 = coerce_ref (arg2);
18af8284
JB
9327 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9328 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 9329
76a01679
JB
9330 if (TYPE_CODE (type1) != TYPE_CODE_INT
9331 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
9332 return value_binop (arg1, arg2, op);
9333
76a01679 9334 switch (op)
4c4b4cd2
PH
9335 {
9336 case BINOP_MOD:
9337 case BINOP_DIV:
9338 case BINOP_REM:
9339 break;
9340 default:
9341 return value_binop (arg1, arg2, op);
9342 }
9343
9344 v2 = value_as_long (arg2);
9345 if (v2 == 0)
323e0a4a 9346 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
9347
9348 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9349 return value_binop (arg1, arg2, op);
9350
9351 v1 = value_as_long (arg1);
9352 switch (op)
9353 {
9354 case BINOP_DIV:
9355 v = v1 / v2;
76a01679
JB
9356 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9357 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
9358 break;
9359 case BINOP_REM:
9360 v = v1 % v2;
76a01679
JB
9361 if (v * v1 < 0)
9362 v -= v2;
4c4b4cd2
PH
9363 break;
9364 default:
9365 /* Should not reach this point. */
9366 v = 0;
9367 }
9368
9369 val = allocate_value (type1);
990a07ab 9370 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9371 TYPE_LENGTH (value_type (val)),
9372 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9373 return val;
9374}
9375
9376static int
9377ada_value_equal (struct value *arg1, struct value *arg2)
9378{
df407dfe
AC
9379 if (ada_is_direct_array_type (value_type (arg1))
9380 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9381 {
f58b38bf
JB
9382 /* Automatically dereference any array reference before
9383 we attempt to perform the comparison. */
9384 arg1 = ada_coerce_ref (arg1);
9385 arg2 = ada_coerce_ref (arg2);
9386
4c4b4cd2
PH
9387 arg1 = ada_coerce_to_simple_array (arg1);
9388 arg2 = ada_coerce_to_simple_array (arg2);
df407dfe
AC
9389 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
9390 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
323e0a4a 9391 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9392 /* FIXME: The following works only for types whose
76a01679
JB
9393 representations use all bits (no padding or undefined bits)
9394 and do not have user-defined equality. */
9395 return
df407dfe 9396 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
0fd88904 9397 && memcmp (value_contents (arg1), value_contents (arg2),
df407dfe 9398 TYPE_LENGTH (value_type (arg1))) == 0;
4c4b4cd2
PH
9399 }
9400 return value_equal (arg1, arg2);
9401}
9402
52ce6436
PH
9403/* Total number of component associations in the aggregate starting at
9404 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9405 OP_AGGREGATE. */
52ce6436
PH
9406
9407static int
9408num_component_specs (struct expression *exp, int pc)
9409{
9410 int n, m, i;
5b4ee69b 9411
52ce6436
PH
9412 m = exp->elts[pc + 1].longconst;
9413 pc += 3;
9414 n = 0;
9415 for (i = 0; i < m; i += 1)
9416 {
9417 switch (exp->elts[pc].opcode)
9418 {
9419 default:
9420 n += 1;
9421 break;
9422 case OP_CHOICES:
9423 n += exp->elts[pc + 1].longconst;
9424 break;
9425 }
9426 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9427 }
9428 return n;
9429}
9430
9431/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9432 component of LHS (a simple array or a record), updating *POS past
9433 the expression, assuming that LHS is contained in CONTAINER. Does
9434 not modify the inferior's memory, nor does it modify LHS (unless
9435 LHS == CONTAINER). */
9436
9437static void
9438assign_component (struct value *container, struct value *lhs, LONGEST index,
9439 struct expression *exp, int *pos)
9440{
9441 struct value *mark = value_mark ();
9442 struct value *elt;
5b4ee69b 9443
52ce6436
PH
9444 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
9445 {
22601c15
UW
9446 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9447 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9448
52ce6436
PH
9449 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9450 }
9451 else
9452 {
9453 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9454 elt = ada_to_fixed_value (elt);
52ce6436
PH
9455 }
9456
9457 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9458 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9459 else
9460 value_assign_to_component (container, elt,
9461 ada_evaluate_subexp (NULL, exp, pos,
9462 EVAL_NORMAL));
9463
9464 value_free_to_mark (mark);
9465}
9466
9467/* Assuming that LHS represents an lvalue having a record or array
9468 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9469 of that aggregate's value to LHS, advancing *POS past the
9470 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9471 lvalue containing LHS (possibly LHS itself). Does not modify
9472 the inferior's memory, nor does it modify the contents of
0963b4bd 9473 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9474
9475static struct value *
9476assign_aggregate (struct value *container,
9477 struct value *lhs, struct expression *exp,
9478 int *pos, enum noside noside)
9479{
9480 struct type *lhs_type;
9481 int n = exp->elts[*pos+1].longconst;
9482 LONGEST low_index, high_index;
9483 int num_specs;
9484 LONGEST *indices;
9485 int max_indices, num_indices;
52ce6436 9486 int i;
52ce6436
PH
9487
9488 *pos += 3;
9489 if (noside != EVAL_NORMAL)
9490 {
52ce6436
PH
9491 for (i = 0; i < n; i += 1)
9492 ada_evaluate_subexp (NULL, exp, pos, noside);
9493 return container;
9494 }
9495
9496 container = ada_coerce_ref (container);
9497 if (ada_is_direct_array_type (value_type (container)))
9498 container = ada_coerce_to_simple_array (container);
9499 lhs = ada_coerce_ref (lhs);
9500 if (!deprecated_value_modifiable (lhs))
9501 error (_("Left operand of assignment is not a modifiable lvalue."));
9502
9503 lhs_type = value_type (lhs);
9504 if (ada_is_direct_array_type (lhs_type))
9505 {
9506 lhs = ada_coerce_to_simple_array (lhs);
9507 lhs_type = value_type (lhs);
9508 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9509 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
9510 }
9511 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9512 {
9513 low_index = 0;
9514 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
9515 }
9516 else
9517 error (_("Left-hand side must be array or record."));
9518
9519 num_specs = num_component_specs (exp, *pos - 3);
9520 max_indices = 4 * num_specs + 4;
9521 indices = alloca (max_indices * sizeof (indices[0]));
9522 indices[0] = indices[1] = low_index - 1;
9523 indices[2] = indices[3] = high_index + 1;
9524 num_indices = 4;
9525
9526 for (i = 0; i < n; i += 1)
9527 {
9528 switch (exp->elts[*pos].opcode)
9529 {
1fbf5ada
JB
9530 case OP_CHOICES:
9531 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9532 &num_indices, max_indices,
9533 low_index, high_index);
9534 break;
9535 case OP_POSITIONAL:
9536 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
9537 &num_indices, max_indices,
9538 low_index, high_index);
1fbf5ada
JB
9539 break;
9540 case OP_OTHERS:
9541 if (i != n-1)
9542 error (_("Misplaced 'others' clause"));
9543 aggregate_assign_others (container, lhs, exp, pos, indices,
9544 num_indices, low_index, high_index);
9545 break;
9546 default:
9547 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
9548 }
9549 }
9550
9551 return container;
9552}
9553
9554/* Assign into the component of LHS indexed by the OP_POSITIONAL
9555 construct at *POS, updating *POS past the construct, given that
9556 the positions are relative to lower bound LOW, where HIGH is the
9557 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9558 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 9559 assign_aggregate. */
52ce6436
PH
9560static void
9561aggregate_assign_positional (struct value *container,
9562 struct value *lhs, struct expression *exp,
9563 int *pos, LONGEST *indices, int *num_indices,
9564 int max_indices, LONGEST low, LONGEST high)
9565{
9566 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9567
9568 if (ind - 1 == high)
e1d5a0d2 9569 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
9570 if (ind <= high)
9571 {
9572 add_component_interval (ind, ind, indices, num_indices, max_indices);
9573 *pos += 3;
9574 assign_component (container, lhs, ind, exp, pos);
9575 }
9576 else
9577 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9578}
9579
9580/* Assign into the components of LHS indexed by the OP_CHOICES
9581 construct at *POS, updating *POS past the construct, given that
9582 the allowable indices are LOW..HIGH. Record the indices assigned
9583 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 9584 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9585static void
9586aggregate_assign_from_choices (struct value *container,
9587 struct value *lhs, struct expression *exp,
9588 int *pos, LONGEST *indices, int *num_indices,
9589 int max_indices, LONGEST low, LONGEST high)
9590{
9591 int j;
9592 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9593 int choice_pos, expr_pc;
9594 int is_array = ada_is_direct_array_type (value_type (lhs));
9595
9596 choice_pos = *pos += 3;
9597
9598 for (j = 0; j < n_choices; j += 1)
9599 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9600 expr_pc = *pos;
9601 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9602
9603 for (j = 0; j < n_choices; j += 1)
9604 {
9605 LONGEST lower, upper;
9606 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 9607
52ce6436
PH
9608 if (op == OP_DISCRETE_RANGE)
9609 {
9610 choice_pos += 1;
9611 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9612 EVAL_NORMAL));
9613 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9614 EVAL_NORMAL));
9615 }
9616 else if (is_array)
9617 {
9618 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9619 EVAL_NORMAL));
9620 upper = lower;
9621 }
9622 else
9623 {
9624 int ind;
0d5cff50 9625 const char *name;
5b4ee69b 9626
52ce6436
PH
9627 switch (op)
9628 {
9629 case OP_NAME:
9630 name = &exp->elts[choice_pos + 2].string;
9631 break;
9632 case OP_VAR_VALUE:
9633 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9634 break;
9635 default:
9636 error (_("Invalid record component association."));
9637 }
9638 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9639 ind = 0;
9640 if (! find_struct_field (name, value_type (lhs), 0,
9641 NULL, NULL, NULL, NULL, &ind))
9642 error (_("Unknown component name: %s."), name);
9643 lower = upper = ind;
9644 }
9645
9646 if (lower <= upper && (lower < low || upper > high))
9647 error (_("Index in component association out of bounds."));
9648
9649 add_component_interval (lower, upper, indices, num_indices,
9650 max_indices);
9651 while (lower <= upper)
9652 {
9653 int pos1;
5b4ee69b 9654
52ce6436
PH
9655 pos1 = expr_pc;
9656 assign_component (container, lhs, lower, exp, &pos1);
9657 lower += 1;
9658 }
9659 }
9660}
9661
9662/* Assign the value of the expression in the OP_OTHERS construct in
9663 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9664 have not been previously assigned. The index intervals already assigned
9665 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 9666 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9667static void
9668aggregate_assign_others (struct value *container,
9669 struct value *lhs, struct expression *exp,
9670 int *pos, LONGEST *indices, int num_indices,
9671 LONGEST low, LONGEST high)
9672{
9673 int i;
5ce64950 9674 int expr_pc = *pos + 1;
52ce6436
PH
9675
9676 for (i = 0; i < num_indices - 2; i += 2)
9677 {
9678 LONGEST ind;
5b4ee69b 9679
52ce6436
PH
9680 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9681 {
5ce64950 9682 int localpos;
5b4ee69b 9683
5ce64950
MS
9684 localpos = expr_pc;
9685 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
9686 }
9687 }
9688 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9689}
9690
9691/* Add the interval [LOW .. HIGH] to the sorted set of intervals
9692 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9693 modifying *SIZE as needed. It is an error if *SIZE exceeds
9694 MAX_SIZE. The resulting intervals do not overlap. */
9695static void
9696add_component_interval (LONGEST low, LONGEST high,
9697 LONGEST* indices, int *size, int max_size)
9698{
9699 int i, j;
5b4ee69b 9700
52ce6436
PH
9701 for (i = 0; i < *size; i += 2) {
9702 if (high >= indices[i] && low <= indices[i + 1])
9703 {
9704 int kh;
5b4ee69b 9705
52ce6436
PH
9706 for (kh = i + 2; kh < *size; kh += 2)
9707 if (high < indices[kh])
9708 break;
9709 if (low < indices[i])
9710 indices[i] = low;
9711 indices[i + 1] = indices[kh - 1];
9712 if (high > indices[i + 1])
9713 indices[i + 1] = high;
9714 memcpy (indices + i + 2, indices + kh, *size - kh);
9715 *size -= kh - i - 2;
9716 return;
9717 }
9718 else if (high < indices[i])
9719 break;
9720 }
9721
9722 if (*size == max_size)
9723 error (_("Internal error: miscounted aggregate components."));
9724 *size += 2;
9725 for (j = *size-1; j >= i+2; j -= 1)
9726 indices[j] = indices[j - 2];
9727 indices[i] = low;
9728 indices[i + 1] = high;
9729}
9730
6e48bd2c
JB
9731/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9732 is different. */
9733
9734static struct value *
9735ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
9736{
9737 if (type == ada_check_typedef (value_type (arg2)))
9738 return arg2;
9739
9740 if (ada_is_fixed_point_type (type))
9741 return (cast_to_fixed (type, arg2));
9742
9743 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9744 return cast_from_fixed (type, arg2);
6e48bd2c
JB
9745
9746 return value_cast (type, arg2);
9747}
9748
284614f0
JB
9749/* Evaluating Ada expressions, and printing their result.
9750 ------------------------------------------------------
9751
21649b50
JB
9752 1. Introduction:
9753 ----------------
9754
284614f0
JB
9755 We usually evaluate an Ada expression in order to print its value.
9756 We also evaluate an expression in order to print its type, which
9757 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9758 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9759 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9760 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9761 similar.
9762
9763 Evaluating expressions is a little more complicated for Ada entities
9764 than it is for entities in languages such as C. The main reason for
9765 this is that Ada provides types whose definition might be dynamic.
9766 One example of such types is variant records. Or another example
9767 would be an array whose bounds can only be known at run time.
9768
9769 The following description is a general guide as to what should be
9770 done (and what should NOT be done) in order to evaluate an expression
9771 involving such types, and when. This does not cover how the semantic
9772 information is encoded by GNAT as this is covered separatly. For the
9773 document used as the reference for the GNAT encoding, see exp_dbug.ads
9774 in the GNAT sources.
9775
9776 Ideally, we should embed each part of this description next to its
9777 associated code. Unfortunately, the amount of code is so vast right
9778 now that it's hard to see whether the code handling a particular
9779 situation might be duplicated or not. One day, when the code is
9780 cleaned up, this guide might become redundant with the comments
9781 inserted in the code, and we might want to remove it.
9782
21649b50
JB
9783 2. ``Fixing'' an Entity, the Simple Case:
9784 -----------------------------------------
9785
284614f0
JB
9786 When evaluating Ada expressions, the tricky issue is that they may
9787 reference entities whose type contents and size are not statically
9788 known. Consider for instance a variant record:
9789
9790 type Rec (Empty : Boolean := True) is record
9791 case Empty is
9792 when True => null;
9793 when False => Value : Integer;
9794 end case;
9795 end record;
9796 Yes : Rec := (Empty => False, Value => 1);
9797 No : Rec := (empty => True);
9798
9799 The size and contents of that record depends on the value of the
9800 descriminant (Rec.Empty). At this point, neither the debugging
9801 information nor the associated type structure in GDB are able to
9802 express such dynamic types. So what the debugger does is to create
9803 "fixed" versions of the type that applies to the specific object.
9804 We also informally refer to this opperation as "fixing" an object,
9805 which means creating its associated fixed type.
9806
9807 Example: when printing the value of variable "Yes" above, its fixed
9808 type would look like this:
9809
9810 type Rec is record
9811 Empty : Boolean;
9812 Value : Integer;
9813 end record;
9814
9815 On the other hand, if we printed the value of "No", its fixed type
9816 would become:
9817
9818 type Rec is record
9819 Empty : Boolean;
9820 end record;
9821
9822 Things become a little more complicated when trying to fix an entity
9823 with a dynamic type that directly contains another dynamic type,
9824 such as an array of variant records, for instance. There are
9825 two possible cases: Arrays, and records.
9826
21649b50
JB
9827 3. ``Fixing'' Arrays:
9828 ---------------------
9829
9830 The type structure in GDB describes an array in terms of its bounds,
9831 and the type of its elements. By design, all elements in the array
9832 have the same type and we cannot represent an array of variant elements
9833 using the current type structure in GDB. When fixing an array,
9834 we cannot fix the array element, as we would potentially need one
9835 fixed type per element of the array. As a result, the best we can do
9836 when fixing an array is to produce an array whose bounds and size
9837 are correct (allowing us to read it from memory), but without having
9838 touched its element type. Fixing each element will be done later,
9839 when (if) necessary.
9840
9841 Arrays are a little simpler to handle than records, because the same
9842 amount of memory is allocated for each element of the array, even if
1b536f04 9843 the amount of space actually used by each element differs from element
21649b50 9844 to element. Consider for instance the following array of type Rec:
284614f0
JB
9845
9846 type Rec_Array is array (1 .. 2) of Rec;
9847
1b536f04
JB
9848 The actual amount of memory occupied by each element might be different
9849 from element to element, depending on the value of their discriminant.
21649b50 9850 But the amount of space reserved for each element in the array remains
1b536f04 9851 fixed regardless. So we simply need to compute that size using
21649b50
JB
9852 the debugging information available, from which we can then determine
9853 the array size (we multiply the number of elements of the array by
9854 the size of each element).
9855
9856 The simplest case is when we have an array of a constrained element
9857 type. For instance, consider the following type declarations:
9858
9859 type Bounded_String (Max_Size : Integer) is
9860 Length : Integer;
9861 Buffer : String (1 .. Max_Size);
9862 end record;
9863 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9864
9865 In this case, the compiler describes the array as an array of
9866 variable-size elements (identified by its XVS suffix) for which
9867 the size can be read in the parallel XVZ variable.
9868
9869 In the case of an array of an unconstrained element type, the compiler
9870 wraps the array element inside a private PAD type. This type should not
9871 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
9872 that we also use the adjective "aligner" in our code to designate
9873 these wrapper types.
9874
1b536f04 9875 In some cases, the size allocated for each element is statically
21649b50
JB
9876 known. In that case, the PAD type already has the correct size,
9877 and the array element should remain unfixed.
9878
9879 But there are cases when this size is not statically known.
9880 For instance, assuming that "Five" is an integer variable:
284614f0
JB
9881
9882 type Dynamic is array (1 .. Five) of Integer;
9883 type Wrapper (Has_Length : Boolean := False) is record
9884 Data : Dynamic;
9885 case Has_Length is
9886 when True => Length : Integer;
9887 when False => null;
9888 end case;
9889 end record;
9890 type Wrapper_Array is array (1 .. 2) of Wrapper;
9891
9892 Hello : Wrapper_Array := (others => (Has_Length => True,
9893 Data => (others => 17),
9894 Length => 1));
9895
9896
9897 The debugging info would describe variable Hello as being an
9898 array of a PAD type. The size of that PAD type is not statically
9899 known, but can be determined using a parallel XVZ variable.
9900 In that case, a copy of the PAD type with the correct size should
9901 be used for the fixed array.
9902
21649b50
JB
9903 3. ``Fixing'' record type objects:
9904 ----------------------------------
9905
9906 Things are slightly different from arrays in the case of dynamic
284614f0
JB
9907 record types. In this case, in order to compute the associated
9908 fixed type, we need to determine the size and offset of each of
9909 its components. This, in turn, requires us to compute the fixed
9910 type of each of these components.
9911
9912 Consider for instance the example:
9913
9914 type Bounded_String (Max_Size : Natural) is record
9915 Str : String (1 .. Max_Size);
9916 Length : Natural;
9917 end record;
9918 My_String : Bounded_String (Max_Size => 10);
9919
9920 In that case, the position of field "Length" depends on the size
9921 of field Str, which itself depends on the value of the Max_Size
21649b50 9922 discriminant. In order to fix the type of variable My_String,
284614f0
JB
9923 we need to fix the type of field Str. Therefore, fixing a variant
9924 record requires us to fix each of its components.
9925
9926 However, if a component does not have a dynamic size, the component
9927 should not be fixed. In particular, fields that use a PAD type
9928 should not fixed. Here is an example where this might happen
9929 (assuming type Rec above):
9930
9931 type Container (Big : Boolean) is record
9932 First : Rec;
9933 After : Integer;
9934 case Big is
9935 when True => Another : Integer;
9936 when False => null;
9937 end case;
9938 end record;
9939 My_Container : Container := (Big => False,
9940 First => (Empty => True),
9941 After => 42);
9942
9943 In that example, the compiler creates a PAD type for component First,
9944 whose size is constant, and then positions the component After just
9945 right after it. The offset of component After is therefore constant
9946 in this case.
9947
9948 The debugger computes the position of each field based on an algorithm
9949 that uses, among other things, the actual position and size of the field
21649b50
JB
9950 preceding it. Let's now imagine that the user is trying to print
9951 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
9952 end up computing the offset of field After based on the size of the
9953 fixed version of field First. And since in our example First has
9954 only one actual field, the size of the fixed type is actually smaller
9955 than the amount of space allocated to that field, and thus we would
9956 compute the wrong offset of field After.
9957
21649b50
JB
9958 To make things more complicated, we need to watch out for dynamic
9959 components of variant records (identified by the ___XVL suffix in
9960 the component name). Even if the target type is a PAD type, the size
9961 of that type might not be statically known. So the PAD type needs
9962 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9963 we might end up with the wrong size for our component. This can be
9964 observed with the following type declarations:
284614f0
JB
9965
9966 type Octal is new Integer range 0 .. 7;
9967 type Octal_Array is array (Positive range <>) of Octal;
9968 pragma Pack (Octal_Array);
9969
9970 type Octal_Buffer (Size : Positive) is record
9971 Buffer : Octal_Array (1 .. Size);
9972 Length : Integer;
9973 end record;
9974
9975 In that case, Buffer is a PAD type whose size is unset and needs
9976 to be computed by fixing the unwrapped type.
9977
21649b50
JB
9978 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9979 ----------------------------------------------------------
9980
9981 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
9982 thus far, be actually fixed?
9983
9984 The answer is: Only when referencing that element. For instance
9985 when selecting one component of a record, this specific component
9986 should be fixed at that point in time. Or when printing the value
9987 of a record, each component should be fixed before its value gets
9988 printed. Similarly for arrays, the element of the array should be
9989 fixed when printing each element of the array, or when extracting
9990 one element out of that array. On the other hand, fixing should
9991 not be performed on the elements when taking a slice of an array!
9992
9993 Note that one of the side-effects of miscomputing the offset and
9994 size of each field is that we end up also miscomputing the size
9995 of the containing type. This can have adverse results when computing
9996 the value of an entity. GDB fetches the value of an entity based
9997 on the size of its type, and thus a wrong size causes GDB to fetch
9998 the wrong amount of memory. In the case where the computed size is
9999 too small, GDB fetches too little data to print the value of our
10000 entiry. Results in this case as unpredicatble, as we usually read
10001 past the buffer containing the data =:-o. */
10002
10003/* Implement the evaluate_exp routine in the exp_descriptor structure
10004 for the Ada language. */
10005
52ce6436 10006static struct value *
ebf56fd3 10007ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 10008 int *pos, enum noside noside)
14f9c5c9
AS
10009{
10010 enum exp_opcode op;
b5385fc0 10011 int tem;
14f9c5c9 10012 int pc;
5ec18f2b 10013 int preeval_pos;
14f9c5c9
AS
10014 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10015 struct type *type;
52ce6436 10016 int nargs, oplen;
d2e4a39e 10017 struct value **argvec;
14f9c5c9 10018
d2e4a39e
AS
10019 pc = *pos;
10020 *pos += 1;
14f9c5c9
AS
10021 op = exp->elts[pc].opcode;
10022
d2e4a39e 10023 switch (op)
14f9c5c9
AS
10024 {
10025 default:
10026 *pos -= 1;
6e48bd2c 10027 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
10028
10029 if (noside == EVAL_NORMAL)
10030 arg1 = unwrap_value (arg1);
6e48bd2c
JB
10031
10032 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
10033 then we need to perform the conversion manually, because
10034 evaluate_subexp_standard doesn't do it. This conversion is
10035 necessary in Ada because the different kinds of float/fixed
10036 types in Ada have different representations.
10037
10038 Similarly, we need to perform the conversion from OP_LONG
10039 ourselves. */
10040 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
10041 arg1 = ada_value_cast (expect_type, arg1, noside);
10042
10043 return arg1;
4c4b4cd2
PH
10044
10045 case OP_STRING:
10046 {
76a01679 10047 struct value *result;
5b4ee69b 10048
76a01679
JB
10049 *pos -= 1;
10050 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10051 /* The result type will have code OP_STRING, bashed there from
10052 OP_ARRAY. Bash it back. */
df407dfe
AC
10053 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10054 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 10055 return result;
4c4b4cd2 10056 }
14f9c5c9
AS
10057
10058 case UNOP_CAST:
10059 (*pos) += 2;
10060 type = exp->elts[pc + 1].type;
10061 arg1 = evaluate_subexp (type, exp, pos, noside);
10062 if (noside == EVAL_SKIP)
4c4b4cd2 10063 goto nosideret;
6e48bd2c 10064 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
10065 return arg1;
10066
4c4b4cd2
PH
10067 case UNOP_QUAL:
10068 (*pos) += 2;
10069 type = exp->elts[pc + 1].type;
10070 return ada_evaluate_subexp (type, exp, pos, noside);
10071
14f9c5c9
AS
10072 case BINOP_ASSIGN:
10073 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
10074 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10075 {
10076 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10077 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10078 return arg1;
10079 return ada_value_assign (arg1, arg1);
10080 }
003f3813
JB
10081 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10082 except if the lhs of our assignment is a convenience variable.
10083 In the case of assigning to a convenience variable, the lhs
10084 should be exactly the result of the evaluation of the rhs. */
10085 type = value_type (arg1);
10086 if (VALUE_LVAL (arg1) == lval_internalvar)
10087 type = NULL;
10088 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 10089 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10090 return arg1;
df407dfe
AC
10091 if (ada_is_fixed_point_type (value_type (arg1)))
10092 arg2 = cast_to_fixed (value_type (arg1), arg2);
10093 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 10094 error
323e0a4a 10095 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 10096 else
df407dfe 10097 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 10098 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
10099
10100 case BINOP_ADD:
10101 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10102 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10103 if (noside == EVAL_SKIP)
4c4b4cd2 10104 goto nosideret;
2ac8a782
JB
10105 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10106 return (value_from_longest
10107 (value_type (arg1),
10108 value_as_long (arg1) + value_as_long (arg2)));
c40cc657
JB
10109 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10110 return (value_from_longest
10111 (value_type (arg2),
10112 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
10113 if ((ada_is_fixed_point_type (value_type (arg1))
10114 || ada_is_fixed_point_type (value_type (arg2)))
10115 && value_type (arg1) != value_type (arg2))
323e0a4a 10116 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
10117 /* Do the addition, and cast the result to the type of the first
10118 argument. We cannot cast the result to a reference type, so if
10119 ARG1 is a reference type, find its underlying type. */
10120 type = value_type (arg1);
10121 while (TYPE_CODE (type) == TYPE_CODE_REF)
10122 type = TYPE_TARGET_TYPE (type);
f44316fa 10123 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10124 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
10125
10126 case BINOP_SUB:
10127 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10128 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10129 if (noside == EVAL_SKIP)
4c4b4cd2 10130 goto nosideret;
2ac8a782
JB
10131 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10132 return (value_from_longest
10133 (value_type (arg1),
10134 value_as_long (arg1) - value_as_long (arg2)));
c40cc657
JB
10135 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10136 return (value_from_longest
10137 (value_type (arg2),
10138 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
10139 if ((ada_is_fixed_point_type (value_type (arg1))
10140 || ada_is_fixed_point_type (value_type (arg2)))
10141 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10142 error (_("Operands of fixed-point subtraction "
10143 "must have the same type"));
b7789565
JB
10144 /* Do the substraction, and cast the result to the type of the first
10145 argument. We cannot cast the result to a reference type, so if
10146 ARG1 is a reference type, find its underlying type. */
10147 type = value_type (arg1);
10148 while (TYPE_CODE (type) == TYPE_CODE_REF)
10149 type = TYPE_TARGET_TYPE (type);
f44316fa 10150 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10151 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10152
10153 case BINOP_MUL:
10154 case BINOP_DIV:
e1578042
JB
10155 case BINOP_REM:
10156 case BINOP_MOD:
14f9c5c9
AS
10157 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10158 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10159 if (noside == EVAL_SKIP)
4c4b4cd2 10160 goto nosideret;
e1578042 10161 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10162 {
10163 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10164 return value_zero (value_type (arg1), not_lval);
10165 }
14f9c5c9 10166 else
4c4b4cd2 10167 {
a53b7a21 10168 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10169 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10170 arg1 = cast_from_fixed (type, arg1);
df407dfe 10171 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10172 arg2 = cast_from_fixed (type, arg2);
f44316fa 10173 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10174 return ada_value_binop (arg1, arg2, op);
10175 }
10176
4c4b4cd2
PH
10177 case BINOP_EQUAL:
10178 case BINOP_NOTEQUAL:
14f9c5c9 10179 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10180 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10181 if (noside == EVAL_SKIP)
76a01679 10182 goto nosideret;
4c4b4cd2 10183 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10184 tem = 0;
4c4b4cd2 10185 else
f44316fa
UW
10186 {
10187 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10188 tem = ada_value_equal (arg1, arg2);
10189 }
4c4b4cd2 10190 if (op == BINOP_NOTEQUAL)
76a01679 10191 tem = !tem;
fbb06eb1
UW
10192 type = language_bool_type (exp->language_defn, exp->gdbarch);
10193 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10194
10195 case UNOP_NEG:
10196 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10197 if (noside == EVAL_SKIP)
10198 goto nosideret;
df407dfe
AC
10199 else if (ada_is_fixed_point_type (value_type (arg1)))
10200 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10201 else
f44316fa
UW
10202 {
10203 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10204 return value_neg (arg1);
10205 }
4c4b4cd2 10206
2330c6c6
JB
10207 case BINOP_LOGICAL_AND:
10208 case BINOP_LOGICAL_OR:
10209 case UNOP_LOGICAL_NOT:
000d5124
JB
10210 {
10211 struct value *val;
10212
10213 *pos -= 1;
10214 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10215 type = language_bool_type (exp->language_defn, exp->gdbarch);
10216 return value_cast (type, val);
000d5124 10217 }
2330c6c6
JB
10218
10219 case BINOP_BITWISE_AND:
10220 case BINOP_BITWISE_IOR:
10221 case BINOP_BITWISE_XOR:
000d5124
JB
10222 {
10223 struct value *val;
10224
10225 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10226 *pos = pc;
10227 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10228
10229 return value_cast (value_type (arg1), val);
10230 }
2330c6c6 10231
14f9c5c9
AS
10232 case OP_VAR_VALUE:
10233 *pos -= 1;
6799def4 10234
14f9c5c9 10235 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10236 {
10237 *pos += 4;
10238 goto nosideret;
10239 }
da5c522f
JB
10240
10241 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10242 /* Only encountered when an unresolved symbol occurs in a
10243 context other than a function call, in which case, it is
52ce6436 10244 invalid. */
323e0a4a 10245 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10246 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
da5c522f
JB
10247
10248 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10249 {
0c1f74cf 10250 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10251 /* Check to see if this is a tagged type. We also need to handle
10252 the case where the type is a reference to a tagged type, but
10253 we have to be careful to exclude pointers to tagged types.
10254 The latter should be shown as usual (as a pointer), whereas
10255 a reference should mostly be transparent to the user. */
10256 if (ada_is_tagged_type (type, 0)
023db19c 10257 || (TYPE_CODE (type) == TYPE_CODE_REF
31dbc1c5 10258 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0d72a7c3
JB
10259 {
10260 /* Tagged types are a little special in the fact that the real
10261 type is dynamic and can only be determined by inspecting the
10262 object's tag. This means that we need to get the object's
10263 value first (EVAL_NORMAL) and then extract the actual object
10264 type from its tag.
10265
10266 Note that we cannot skip the final step where we extract
10267 the object type from its tag, because the EVAL_NORMAL phase
10268 results in dynamic components being resolved into fixed ones.
10269 This can cause problems when trying to print the type
10270 description of tagged types whose parent has a dynamic size:
10271 We use the type name of the "_parent" component in order
10272 to print the name of the ancestor type in the type description.
10273 If that component had a dynamic size, the resolution into
10274 a fixed type would result in the loss of that type name,
10275 thus preventing us from printing the name of the ancestor
10276 type in the type description. */
10277 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10278
10279 if (TYPE_CODE (type) != TYPE_CODE_REF)
10280 {
10281 struct type *actual_type;
10282
10283 actual_type = type_from_tag (ada_value_tag (arg1));
10284 if (actual_type == NULL)
10285 /* If, for some reason, we were unable to determine
10286 the actual type from the tag, then use the static
10287 approximation that we just computed as a fallback.
10288 This can happen if the debugging information is
10289 incomplete, for instance. */
10290 actual_type = type;
10291 return value_zero (actual_type, not_lval);
10292 }
10293 else
10294 {
10295 /* In the case of a ref, ada_coerce_ref takes care
10296 of determining the actual type. But the evaluation
10297 should return a ref as it should be valid to ask
10298 for its address; so rebuild a ref after coerce. */
10299 arg1 = ada_coerce_ref (arg1);
10300 return value_ref (arg1);
10301 }
10302 }
0c1f74cf 10303
84754697
JB
10304 /* Records and unions for which GNAT encodings have been
10305 generated need to be statically fixed as well.
10306 Otherwise, non-static fixing produces a type where
10307 all dynamic properties are removed, which prevents "ptype"
10308 from being able to completely describe the type.
10309 For instance, a case statement in a variant record would be
10310 replaced by the relevant components based on the actual
10311 value of the discriminants. */
10312 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10313 && dynamic_template_type (type) != NULL)
10314 || (TYPE_CODE (type) == TYPE_CODE_UNION
10315 && ada_find_parallel_type (type, "___XVU") != NULL))
10316 {
10317 *pos += 4;
10318 return value_zero (to_static_fixed_type (type), not_lval);
10319 }
4c4b4cd2 10320 }
da5c522f
JB
10321
10322 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10323 return ada_to_fixed_value (arg1);
4c4b4cd2
PH
10324
10325 case OP_FUNCALL:
10326 (*pos) += 2;
10327
10328 /* Allocate arg vector, including space for the function to be
10329 called in argvec[0] and a terminating NULL. */
10330 nargs = longest_to_int (exp->elts[pc + 1].longconst);
10331 argvec =
10332 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
10333
10334 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10335 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10336 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10337 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10338 else
10339 {
10340 for (tem = 0; tem <= nargs; tem += 1)
10341 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10342 argvec[tem] = 0;
10343
10344 if (noside == EVAL_SKIP)
10345 goto nosideret;
10346 }
10347
ad82864c
JB
10348 if (ada_is_constrained_packed_array_type
10349 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10350 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10351 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10352 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10353 /* This is a packed array that has already been fixed, and
10354 therefore already coerced to a simple array. Nothing further
10355 to do. */
10356 ;
df407dfe
AC
10357 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
10358 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
76a01679 10359 && VALUE_LVAL (argvec[0]) == lval_memory))
4c4b4cd2
PH
10360 argvec[0] = value_addr (argvec[0]);
10361
df407dfe 10362 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10363
10364 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10365 them. So, if this is an array typedef (encoding use for array
10366 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10367 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10368 type = ada_typedef_target_type (type);
10369
4c4b4cd2
PH
10370 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10371 {
61ee279c 10372 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10373 {
10374 case TYPE_CODE_FUNC:
61ee279c 10375 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10376 break;
10377 case TYPE_CODE_ARRAY:
10378 break;
10379 case TYPE_CODE_STRUCT:
10380 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10381 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10382 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10383 break;
10384 default:
323e0a4a 10385 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10386 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10387 break;
10388 }
10389 }
10390
10391 switch (TYPE_CODE (type))
10392 {
10393 case TYPE_CODE_FUNC:
10394 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972
PH
10395 {
10396 struct type *rtype = TYPE_TARGET_TYPE (type);
10397
10398 if (TYPE_GNU_IFUNC (type))
10399 return allocate_value (TYPE_TARGET_TYPE (rtype));
10400 return allocate_value (rtype);
10401 }
4c4b4cd2 10402 return call_function_by_hand (argvec[0], nargs, argvec + 1);
c8ea1972
PH
10403 case TYPE_CODE_INTERNAL_FUNCTION:
10404 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10405 /* We don't know anything about what the internal
10406 function might return, but we have to return
10407 something. */
10408 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10409 not_lval);
10410 else
10411 return call_internal_function (exp->gdbarch, exp->language_defn,
10412 argvec[0], nargs, argvec + 1);
10413
4c4b4cd2
PH
10414 case TYPE_CODE_STRUCT:
10415 {
10416 int arity;
10417
4c4b4cd2
PH
10418 arity = ada_array_arity (type);
10419 type = ada_array_element_type (type, nargs);
10420 if (type == NULL)
323e0a4a 10421 error (_("cannot subscript or call a record"));
4c4b4cd2 10422 if (arity != nargs)
323e0a4a 10423 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10424 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10425 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10426 return
10427 unwrap_value (ada_value_subscript
10428 (argvec[0], nargs, argvec + 1));
10429 }
10430 case TYPE_CODE_ARRAY:
10431 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10432 {
10433 type = ada_array_element_type (type, nargs);
10434 if (type == NULL)
323e0a4a 10435 error (_("element type of array unknown"));
4c4b4cd2 10436 else
0a07e705 10437 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10438 }
10439 return
10440 unwrap_value (ada_value_subscript
10441 (ada_coerce_to_simple_array (argvec[0]),
10442 nargs, argvec + 1));
10443 case TYPE_CODE_PTR: /* Pointer to array */
4c4b4cd2
PH
10444 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10445 {
deede10c 10446 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
4c4b4cd2
PH
10447 type = ada_array_element_type (type, nargs);
10448 if (type == NULL)
323e0a4a 10449 error (_("element type of array unknown"));
4c4b4cd2 10450 else
0a07e705 10451 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10452 }
10453 return
deede10c
JB
10454 unwrap_value (ada_value_ptr_subscript (argvec[0],
10455 nargs, argvec + 1));
4c4b4cd2
PH
10456
10457 default:
e1d5a0d2
PH
10458 error (_("Attempt to index or call something other than an "
10459 "array or function"));
4c4b4cd2
PH
10460 }
10461
10462 case TERNOP_SLICE:
10463 {
10464 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10465 struct value *low_bound_val =
10466 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
10467 struct value *high_bound_val =
10468 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10469 LONGEST low_bound;
10470 LONGEST high_bound;
5b4ee69b 10471
994b9211
AC
10472 low_bound_val = coerce_ref (low_bound_val);
10473 high_bound_val = coerce_ref (high_bound_val);
714e53ab
PH
10474 low_bound = pos_atr (low_bound_val);
10475 high_bound = pos_atr (high_bound_val);
963a6417 10476
4c4b4cd2
PH
10477 if (noside == EVAL_SKIP)
10478 goto nosideret;
10479
4c4b4cd2
PH
10480 /* If this is a reference to an aligner type, then remove all
10481 the aligners. */
df407dfe
AC
10482 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10483 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10484 TYPE_TARGET_TYPE (value_type (array)) =
10485 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 10486
ad82864c 10487 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 10488 error (_("cannot slice a packed array"));
4c4b4cd2
PH
10489
10490 /* If this is a reference to an array or an array lvalue,
10491 convert to a pointer. */
df407dfe
AC
10492 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10493 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
10494 && VALUE_LVAL (array) == lval_memory))
10495 array = value_addr (array);
10496
1265e4aa 10497 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 10498 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 10499 (value_type (array))))
0b5d8877 10500 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
10501
10502 array = ada_coerce_to_simple_array_ptr (array);
10503
714e53ab
PH
10504 /* If we have more than one level of pointer indirection,
10505 dereference the value until we get only one level. */
df407dfe
AC
10506 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10507 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
10508 == TYPE_CODE_PTR))
10509 array = value_ind (array);
10510
10511 /* Make sure we really do have an array type before going further,
10512 to avoid a SEGV when trying to get the index type or the target
10513 type later down the road if the debug info generated by
10514 the compiler is incorrect or incomplete. */
df407dfe 10515 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 10516 error (_("cannot take slice of non-array"));
714e53ab 10517
828292f2
JB
10518 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10519 == TYPE_CODE_PTR)
4c4b4cd2 10520 {
828292f2
JB
10521 struct type *type0 = ada_check_typedef (value_type (array));
10522
0b5d8877 10523 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 10524 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
10525 else
10526 {
10527 struct type *arr_type0 =
828292f2 10528 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 10529
f5938064
JG
10530 return ada_value_slice_from_ptr (array, arr_type0,
10531 longest_to_int (low_bound),
10532 longest_to_int (high_bound));
4c4b4cd2
PH
10533 }
10534 }
10535 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10536 return array;
10537 else if (high_bound < low_bound)
df407dfe 10538 return empty_array (value_type (array), low_bound);
4c4b4cd2 10539 else
529cad9c
PH
10540 return ada_value_slice (array, longest_to_int (low_bound),
10541 longest_to_int (high_bound));
4c4b4cd2 10542 }
14f9c5c9 10543
4c4b4cd2
PH
10544 case UNOP_IN_RANGE:
10545 (*pos) += 2;
10546 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 10547 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 10548
14f9c5c9 10549 if (noside == EVAL_SKIP)
4c4b4cd2 10550 goto nosideret;
14f9c5c9 10551
4c4b4cd2
PH
10552 switch (TYPE_CODE (type))
10553 {
10554 default:
e1d5a0d2
PH
10555 lim_warning (_("Membership test incompletely implemented; "
10556 "always returns true"));
fbb06eb1
UW
10557 type = language_bool_type (exp->language_defn, exp->gdbarch);
10558 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
10559
10560 case TYPE_CODE_RANGE:
030b4912
UW
10561 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10562 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
10563 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10564 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
10565 type = language_bool_type (exp->language_defn, exp->gdbarch);
10566 return
10567 value_from_longest (type,
4c4b4cd2
PH
10568 (value_less (arg1, arg3)
10569 || value_equal (arg1, arg3))
10570 && (value_less (arg2, arg1)
10571 || value_equal (arg2, arg1)));
10572 }
10573
10574 case BINOP_IN_BOUNDS:
14f9c5c9 10575 (*pos) += 2;
4c4b4cd2
PH
10576 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10577 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10578
4c4b4cd2
PH
10579 if (noside == EVAL_SKIP)
10580 goto nosideret;
14f9c5c9 10581
4c4b4cd2 10582 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
10583 {
10584 type = language_bool_type (exp->language_defn, exp->gdbarch);
10585 return value_zero (type, not_lval);
10586 }
14f9c5c9 10587
4c4b4cd2 10588 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 10589
1eea4ebd
UW
10590 type = ada_index_type (value_type (arg2), tem, "range");
10591 if (!type)
10592 type = value_type (arg1);
14f9c5c9 10593
1eea4ebd
UW
10594 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10595 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 10596
f44316fa
UW
10597 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10598 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10599 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10600 return
fbb06eb1 10601 value_from_longest (type,
4c4b4cd2
PH
10602 (value_less (arg1, arg3)
10603 || value_equal (arg1, arg3))
10604 && (value_less (arg2, arg1)
10605 || value_equal (arg2, arg1)));
10606
10607 case TERNOP_IN_RANGE:
10608 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10609 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10610 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10611
10612 if (noside == EVAL_SKIP)
10613 goto nosideret;
10614
f44316fa
UW
10615 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10616 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10617 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10618 return
fbb06eb1 10619 value_from_longest (type,
4c4b4cd2
PH
10620 (value_less (arg1, arg3)
10621 || value_equal (arg1, arg3))
10622 && (value_less (arg2, arg1)
10623 || value_equal (arg2, arg1)));
10624
10625 case OP_ATR_FIRST:
10626 case OP_ATR_LAST:
10627 case OP_ATR_LENGTH:
10628 {
76a01679 10629 struct type *type_arg;
5b4ee69b 10630
76a01679
JB
10631 if (exp->elts[*pos].opcode == OP_TYPE)
10632 {
10633 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10634 arg1 = NULL;
5bc23cb3 10635 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
10636 }
10637 else
10638 {
10639 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10640 type_arg = NULL;
10641 }
10642
10643 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 10644 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
10645 tem = longest_to_int (exp->elts[*pos + 2].longconst);
10646 *pos += 4;
10647
10648 if (noside == EVAL_SKIP)
10649 goto nosideret;
10650
10651 if (type_arg == NULL)
10652 {
10653 arg1 = ada_coerce_ref (arg1);
10654
ad82864c 10655 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
10656 arg1 = ada_coerce_to_simple_array (arg1);
10657
aa4fb036 10658 if (op == OP_ATR_LENGTH)
1eea4ebd 10659 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
10660 else
10661 {
10662 type = ada_index_type (value_type (arg1), tem,
10663 ada_attribute_name (op));
10664 if (type == NULL)
10665 type = builtin_type (exp->gdbarch)->builtin_int;
10666 }
76a01679
JB
10667
10668 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 10669 return allocate_value (type);
76a01679
JB
10670
10671 switch (op)
10672 {
10673 default: /* Should never happen. */
323e0a4a 10674 error (_("unexpected attribute encountered"));
76a01679 10675 case OP_ATR_FIRST:
1eea4ebd
UW
10676 return value_from_longest
10677 (type, ada_array_bound (arg1, tem, 0));
76a01679 10678 case OP_ATR_LAST:
1eea4ebd
UW
10679 return value_from_longest
10680 (type, ada_array_bound (arg1, tem, 1));
76a01679 10681 case OP_ATR_LENGTH:
1eea4ebd
UW
10682 return value_from_longest
10683 (type, ada_array_length (arg1, tem));
76a01679
JB
10684 }
10685 }
10686 else if (discrete_type_p (type_arg))
10687 {
10688 struct type *range_type;
0d5cff50 10689 const char *name = ada_type_name (type_arg);
5b4ee69b 10690
76a01679
JB
10691 range_type = NULL;
10692 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 10693 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
10694 if (range_type == NULL)
10695 range_type = type_arg;
10696 switch (op)
10697 {
10698 default:
323e0a4a 10699 error (_("unexpected attribute encountered"));
76a01679 10700 case OP_ATR_FIRST:
690cc4eb 10701 return value_from_longest
43bbcdc2 10702 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 10703 case OP_ATR_LAST:
690cc4eb 10704 return value_from_longest
43bbcdc2 10705 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 10706 case OP_ATR_LENGTH:
323e0a4a 10707 error (_("the 'length attribute applies only to array types"));
76a01679
JB
10708 }
10709 }
10710 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 10711 error (_("unimplemented type attribute"));
76a01679
JB
10712 else
10713 {
10714 LONGEST low, high;
10715
ad82864c
JB
10716 if (ada_is_constrained_packed_array_type (type_arg))
10717 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 10718
aa4fb036 10719 if (op == OP_ATR_LENGTH)
1eea4ebd 10720 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
10721 else
10722 {
10723 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10724 if (type == NULL)
10725 type = builtin_type (exp->gdbarch)->builtin_int;
10726 }
1eea4ebd 10727
76a01679
JB
10728 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10729 return allocate_value (type);
10730
10731 switch (op)
10732 {
10733 default:
323e0a4a 10734 error (_("unexpected attribute encountered"));
76a01679 10735 case OP_ATR_FIRST:
1eea4ebd 10736 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
10737 return value_from_longest (type, low);
10738 case OP_ATR_LAST:
1eea4ebd 10739 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10740 return value_from_longest (type, high);
10741 case OP_ATR_LENGTH:
1eea4ebd
UW
10742 low = ada_array_bound_from_type (type_arg, tem, 0);
10743 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10744 return value_from_longest (type, high - low + 1);
10745 }
10746 }
14f9c5c9
AS
10747 }
10748
4c4b4cd2
PH
10749 case OP_ATR_TAG:
10750 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10751 if (noside == EVAL_SKIP)
76a01679 10752 goto nosideret;
4c4b4cd2
PH
10753
10754 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10755 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
10756
10757 return ada_value_tag (arg1);
10758
10759 case OP_ATR_MIN:
10760 case OP_ATR_MAX:
10761 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10762 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10763 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10764 if (noside == EVAL_SKIP)
76a01679 10765 goto nosideret;
d2e4a39e 10766 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10767 return value_zero (value_type (arg1), not_lval);
14f9c5c9 10768 else
f44316fa
UW
10769 {
10770 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10771 return value_binop (arg1, arg2,
10772 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
10773 }
14f9c5c9 10774
4c4b4cd2
PH
10775 case OP_ATR_MODULUS:
10776 {
31dedfee 10777 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 10778
5b4ee69b 10779 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
10780 if (noside == EVAL_SKIP)
10781 goto nosideret;
4c4b4cd2 10782
76a01679 10783 if (!ada_is_modular_type (type_arg))
323e0a4a 10784 error (_("'modulus must be applied to modular type"));
4c4b4cd2 10785
76a01679
JB
10786 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
10787 ada_modulus (type_arg));
4c4b4cd2
PH
10788 }
10789
10790
10791 case OP_ATR_POS:
10792 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10793 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10794 if (noside == EVAL_SKIP)
76a01679 10795 goto nosideret;
3cb382c9
UW
10796 type = builtin_type (exp->gdbarch)->builtin_int;
10797 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10798 return value_zero (type, not_lval);
14f9c5c9 10799 else
3cb382c9 10800 return value_pos_atr (type, arg1);
14f9c5c9 10801
4c4b4cd2
PH
10802 case OP_ATR_SIZE:
10803 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
10804 type = value_type (arg1);
10805
10806 /* If the argument is a reference, then dereference its type, since
10807 the user is really asking for the size of the actual object,
10808 not the size of the pointer. */
10809 if (TYPE_CODE (type) == TYPE_CODE_REF)
10810 type = TYPE_TARGET_TYPE (type);
10811
4c4b4cd2 10812 if (noside == EVAL_SKIP)
76a01679 10813 goto nosideret;
4c4b4cd2 10814 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 10815 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 10816 else
22601c15 10817 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 10818 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
10819
10820 case OP_ATR_VAL:
10821 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 10822 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 10823 type = exp->elts[pc + 2].type;
14f9c5c9 10824 if (noside == EVAL_SKIP)
76a01679 10825 goto nosideret;
4c4b4cd2 10826 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10827 return value_zero (type, not_lval);
4c4b4cd2 10828 else
76a01679 10829 return value_val_atr (type, arg1);
4c4b4cd2
PH
10830
10831 case BINOP_EXP:
10832 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10833 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10834 if (noside == EVAL_SKIP)
10835 goto nosideret;
10836 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10837 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 10838 else
f44316fa
UW
10839 {
10840 /* For integer exponentiation operations,
10841 only promote the first argument. */
10842 if (is_integral_type (value_type (arg2)))
10843 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10844 else
10845 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10846
10847 return value_binop (arg1, arg2, op);
10848 }
4c4b4cd2
PH
10849
10850 case UNOP_PLUS:
10851 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10852 if (noside == EVAL_SKIP)
10853 goto nosideret;
10854 else
10855 return arg1;
10856
10857 case UNOP_ABS:
10858 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10859 if (noside == EVAL_SKIP)
10860 goto nosideret;
f44316fa 10861 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 10862 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 10863 return value_neg (arg1);
14f9c5c9 10864 else
4c4b4cd2 10865 return arg1;
14f9c5c9
AS
10866
10867 case UNOP_IND:
5ec18f2b 10868 preeval_pos = *pos;
6b0d7253 10869 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10870 if (noside == EVAL_SKIP)
4c4b4cd2 10871 goto nosideret;
df407dfe 10872 type = ada_check_typedef (value_type (arg1));
14f9c5c9 10873 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
10874 {
10875 if (ada_is_array_descriptor_type (type))
10876 /* GDB allows dereferencing GNAT array descriptors. */
10877 {
10878 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 10879
4c4b4cd2 10880 if (arrType == NULL)
323e0a4a 10881 error (_("Attempt to dereference null array pointer."));
00a4c844 10882 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
10883 }
10884 else if (TYPE_CODE (type) == TYPE_CODE_PTR
10885 || TYPE_CODE (type) == TYPE_CODE_REF
10886 /* In C you can dereference an array to get the 1st elt. */
10887 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab 10888 {
5ec18f2b
JG
10889 /* As mentioned in the OP_VAR_VALUE case, tagged types can
10890 only be determined by inspecting the object's tag.
10891 This means that we need to evaluate completely the
10892 expression in order to get its type. */
10893
023db19c
JB
10894 if ((TYPE_CODE (type) == TYPE_CODE_REF
10895 || TYPE_CODE (type) == TYPE_CODE_PTR)
5ec18f2b
JG
10896 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
10897 {
10898 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
10899 EVAL_NORMAL);
10900 type = value_type (ada_value_ind (arg1));
10901 }
10902 else
10903 {
10904 type = to_static_fixed_type
10905 (ada_aligned_type
10906 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10907 }
c1b5a1a6 10908 ada_ensure_varsize_limit (type);
714e53ab
PH
10909 return value_zero (type, lval_memory);
10910 }
4c4b4cd2 10911 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
10912 {
10913 /* GDB allows dereferencing an int. */
10914 if (expect_type == NULL)
10915 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10916 lval_memory);
10917 else
10918 {
10919 expect_type =
10920 to_static_fixed_type (ada_aligned_type (expect_type));
10921 return value_zero (expect_type, lval_memory);
10922 }
10923 }
4c4b4cd2 10924 else
323e0a4a 10925 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 10926 }
0963b4bd 10927 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 10928 type = ada_check_typedef (value_type (arg1));
d2e4a39e 10929
96967637
JB
10930 if (TYPE_CODE (type) == TYPE_CODE_INT)
10931 /* GDB allows dereferencing an int. If we were given
10932 the expect_type, then use that as the target type.
10933 Otherwise, assume that the target type is an int. */
10934 {
10935 if (expect_type != NULL)
10936 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10937 arg1));
10938 else
10939 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10940 (CORE_ADDR) value_as_address (arg1));
10941 }
6b0d7253 10942
4c4b4cd2
PH
10943 if (ada_is_array_descriptor_type (type))
10944 /* GDB allows dereferencing GNAT array descriptors. */
10945 return ada_coerce_to_simple_array (arg1);
14f9c5c9 10946 else
4c4b4cd2 10947 return ada_value_ind (arg1);
14f9c5c9
AS
10948
10949 case STRUCTOP_STRUCT:
10950 tem = longest_to_int (exp->elts[pc + 1].longconst);
10951 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
5ec18f2b 10952 preeval_pos = *pos;
14f9c5c9
AS
10953 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10954 if (noside == EVAL_SKIP)
4c4b4cd2 10955 goto nosideret;
14f9c5c9 10956 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10957 {
df407dfe 10958 struct type *type1 = value_type (arg1);
5b4ee69b 10959
76a01679
JB
10960 if (ada_is_tagged_type (type1, 1))
10961 {
10962 type = ada_lookup_struct_elt_type (type1,
10963 &exp->elts[pc + 2].string,
10964 1, 1, NULL);
5ec18f2b
JG
10965
10966 /* If the field is not found, check if it exists in the
10967 extension of this object's type. This means that we
10968 need to evaluate completely the expression. */
10969
76a01679 10970 if (type == NULL)
5ec18f2b
JG
10971 {
10972 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
10973 EVAL_NORMAL);
10974 arg1 = ada_value_struct_elt (arg1,
10975 &exp->elts[pc + 2].string,
10976 0);
10977 arg1 = unwrap_value (arg1);
10978 type = value_type (ada_to_fixed_value (arg1));
10979 }
76a01679
JB
10980 }
10981 else
10982 type =
10983 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
10984 0, NULL);
10985
10986 return value_zero (ada_aligned_type (type), lval_memory);
10987 }
14f9c5c9 10988 else
284614f0
JB
10989 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
10990 arg1 = unwrap_value (arg1);
10991 return ada_to_fixed_value (arg1);
10992
14f9c5c9 10993 case OP_TYPE:
4c4b4cd2
PH
10994 /* The value is not supposed to be used. This is here to make it
10995 easier to accommodate expressions that contain types. */
14f9c5c9
AS
10996 (*pos) += 2;
10997 if (noside == EVAL_SKIP)
4c4b4cd2 10998 goto nosideret;
14f9c5c9 10999 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 11000 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 11001 else
323e0a4a 11002 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
11003
11004 case OP_AGGREGATE:
11005 case OP_CHOICES:
11006 case OP_OTHERS:
11007 case OP_DISCRETE_RANGE:
11008 case OP_POSITIONAL:
11009 case OP_NAME:
11010 if (noside == EVAL_NORMAL)
11011 switch (op)
11012 {
11013 case OP_NAME:
11014 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 11015 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
11016 case OP_AGGREGATE:
11017 error (_("Aggregates only allowed on the right of an assignment"));
11018 default:
0963b4bd
MS
11019 internal_error (__FILE__, __LINE__,
11020 _("aggregate apparently mangled"));
52ce6436
PH
11021 }
11022
11023 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11024 *pos += oplen - 1;
11025 for (tem = 0; tem < nargs; tem += 1)
11026 ada_evaluate_subexp (NULL, exp, pos, noside);
11027 goto nosideret;
14f9c5c9
AS
11028 }
11029
11030nosideret:
22601c15 11031 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
14f9c5c9 11032}
14f9c5c9 11033\f
d2e4a39e 11034
4c4b4cd2 11035 /* Fixed point */
14f9c5c9
AS
11036
11037/* If TYPE encodes an Ada fixed-point type, return the suffix of the
11038 type name that encodes the 'small and 'delta information.
4c4b4cd2 11039 Otherwise, return NULL. */
14f9c5c9 11040
d2e4a39e 11041static const char *
ebf56fd3 11042fixed_type_info (struct type *type)
14f9c5c9 11043{
d2e4a39e 11044 const char *name = ada_type_name (type);
14f9c5c9
AS
11045 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11046
d2e4a39e
AS
11047 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11048 {
14f9c5c9 11049 const char *tail = strstr (name, "___XF_");
5b4ee69b 11050
14f9c5c9 11051 if (tail == NULL)
4c4b4cd2 11052 return NULL;
d2e4a39e 11053 else
4c4b4cd2 11054 return tail + 5;
14f9c5c9
AS
11055 }
11056 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11057 return fixed_type_info (TYPE_TARGET_TYPE (type));
11058 else
11059 return NULL;
11060}
11061
4c4b4cd2 11062/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
11063
11064int
ebf56fd3 11065ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
11066{
11067 return fixed_type_info (type) != NULL;
11068}
11069
4c4b4cd2
PH
11070/* Return non-zero iff TYPE represents a System.Address type. */
11071
11072int
11073ada_is_system_address_type (struct type *type)
11074{
11075 return (TYPE_NAME (type)
11076 && strcmp (TYPE_NAME (type), "system__address") == 0);
11077}
11078
14f9c5c9
AS
11079/* Assuming that TYPE is the representation of an Ada fixed-point
11080 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 11081 delta cannot be determined. */
14f9c5c9
AS
11082
11083DOUBLEST
ebf56fd3 11084ada_delta (struct type *type)
14f9c5c9
AS
11085{
11086 const char *encoding = fixed_type_info (type);
facc390f 11087 DOUBLEST num, den;
14f9c5c9 11088
facc390f
JB
11089 /* Strictly speaking, num and den are encoded as integer. However,
11090 they may not fit into a long, and they will have to be converted
11091 to DOUBLEST anyway. So scan them as DOUBLEST. */
11092 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
11093 &num, &den) < 2)
14f9c5c9 11094 return -1.0;
d2e4a39e 11095 else
facc390f 11096 return num / den;
14f9c5c9
AS
11097}
11098
11099/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 11100 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
11101
11102static DOUBLEST
ebf56fd3 11103scaling_factor (struct type *type)
14f9c5c9
AS
11104{
11105 const char *encoding = fixed_type_info (type);
facc390f 11106 DOUBLEST num0, den0, num1, den1;
14f9c5c9 11107 int n;
d2e4a39e 11108
facc390f
JB
11109 /* Strictly speaking, num's and den's are encoded as integer. However,
11110 they may not fit into a long, and they will have to be converted
11111 to DOUBLEST anyway. So scan them as DOUBLEST. */
11112 n = sscanf (encoding,
11113 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
11114 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
11115 &num0, &den0, &num1, &den1);
14f9c5c9
AS
11116
11117 if (n < 2)
11118 return 1.0;
11119 else if (n == 4)
facc390f 11120 return num1 / den1;
d2e4a39e 11121 else
facc390f 11122 return num0 / den0;
14f9c5c9
AS
11123}
11124
11125
11126/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 11127 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
11128
11129DOUBLEST
ebf56fd3 11130ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 11131{
d2e4a39e 11132 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
11133}
11134
4c4b4cd2
PH
11135/* The representation of a fixed-point value of type TYPE
11136 corresponding to the value X. */
14f9c5c9
AS
11137
11138LONGEST
ebf56fd3 11139ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
11140{
11141 return (LONGEST) (x / scaling_factor (type) + 0.5);
11142}
11143
14f9c5c9 11144\f
d2e4a39e 11145
4c4b4cd2 11146 /* Range types */
14f9c5c9
AS
11147
11148/* Scan STR beginning at position K for a discriminant name, and
11149 return the value of that discriminant field of DVAL in *PX. If
11150 PNEW_K is not null, put the position of the character beyond the
11151 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 11152 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
11153
11154static int
07d8f827 11155scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
76a01679 11156 int *pnew_k)
14f9c5c9
AS
11157{
11158 static char *bound_buffer = NULL;
11159 static size_t bound_buffer_len = 0;
11160 char *bound;
11161 char *pend;
d2e4a39e 11162 struct value *bound_val;
14f9c5c9
AS
11163
11164 if (dval == NULL || str == NULL || str[k] == '\0')
11165 return 0;
11166
d2e4a39e 11167 pend = strstr (str + k, "__");
14f9c5c9
AS
11168 if (pend == NULL)
11169 {
d2e4a39e 11170 bound = str + k;
14f9c5c9
AS
11171 k += strlen (bound);
11172 }
d2e4a39e 11173 else
14f9c5c9 11174 {
d2e4a39e 11175 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
14f9c5c9 11176 bound = bound_buffer;
d2e4a39e
AS
11177 strncpy (bound_buffer, str + k, pend - (str + k));
11178 bound[pend - (str + k)] = '\0';
11179 k = pend - str;
14f9c5c9 11180 }
d2e4a39e 11181
df407dfe 11182 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11183 if (bound_val == NULL)
11184 return 0;
11185
11186 *px = value_as_long (bound_val);
11187 if (pnew_k != NULL)
11188 *pnew_k = k;
11189 return 1;
11190}
11191
11192/* Value of variable named NAME in the current environment. If
11193 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11194 otherwise causes an error with message ERR_MSG. */
11195
d2e4a39e
AS
11196static struct value *
11197get_var_value (char *name, char *err_msg)
14f9c5c9 11198{
4c4b4cd2 11199 struct ada_symbol_info *syms;
14f9c5c9
AS
11200 int nsyms;
11201
4c4b4cd2 11202 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
4eeaa230 11203 &syms);
14f9c5c9
AS
11204
11205 if (nsyms != 1)
11206 {
11207 if (err_msg == NULL)
4c4b4cd2 11208 return 0;
14f9c5c9 11209 else
8a3fe4f8 11210 error (("%s"), err_msg);
14f9c5c9
AS
11211 }
11212
4c4b4cd2 11213 return value_of_variable (syms[0].sym, syms[0].block);
14f9c5c9 11214}
d2e4a39e 11215
14f9c5c9 11216/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
11217 no such variable found, returns 0, and sets *FLAG to 0. If
11218 successful, sets *FLAG to 1. */
11219
14f9c5c9 11220LONGEST
4c4b4cd2 11221get_int_var_value (char *name, int *flag)
14f9c5c9 11222{
4c4b4cd2 11223 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11224
14f9c5c9
AS
11225 if (var_val == 0)
11226 {
11227 if (flag != NULL)
4c4b4cd2 11228 *flag = 0;
14f9c5c9
AS
11229 return 0;
11230 }
11231 else
11232 {
11233 if (flag != NULL)
4c4b4cd2 11234 *flag = 1;
14f9c5c9
AS
11235 return value_as_long (var_val);
11236 }
11237}
d2e4a39e 11238
14f9c5c9
AS
11239
11240/* Return a range type whose base type is that of the range type named
11241 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11242 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11243 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11244 corresponding range type from debug information; fall back to using it
11245 if symbol lookup fails. If a new type must be created, allocate it
11246 like ORIG_TYPE was. The bounds information, in general, is encoded
11247 in NAME, the base type given in the named range type. */
14f9c5c9 11248
d2e4a39e 11249static struct type *
28c85d6c 11250to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11251{
0d5cff50 11252 const char *name;
14f9c5c9 11253 struct type *base_type;
d2e4a39e 11254 char *subtype_info;
14f9c5c9 11255
28c85d6c
JB
11256 gdb_assert (raw_type != NULL);
11257 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11258
1ce677a4 11259 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11260 base_type = TYPE_TARGET_TYPE (raw_type);
11261 else
11262 base_type = raw_type;
11263
28c85d6c 11264 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11265 subtype_info = strstr (name, "___XD");
11266 if (subtype_info == NULL)
690cc4eb 11267 {
43bbcdc2
PH
11268 LONGEST L = ada_discrete_type_low_bound (raw_type);
11269 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11270
690cc4eb
PH
11271 if (L < INT_MIN || U > INT_MAX)
11272 return raw_type;
11273 else
0c9c3474
SA
11274 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11275 L, U);
690cc4eb 11276 }
14f9c5c9
AS
11277 else
11278 {
11279 static char *name_buf = NULL;
11280 static size_t name_len = 0;
11281 int prefix_len = subtype_info - name;
11282 LONGEST L, U;
11283 struct type *type;
11284 char *bounds_str;
11285 int n;
11286
11287 GROW_VECT (name_buf, name_len, prefix_len + 5);
11288 strncpy (name_buf, name, prefix_len);
11289 name_buf[prefix_len] = '\0';
11290
11291 subtype_info += 5;
11292 bounds_str = strchr (subtype_info, '_');
11293 n = 1;
11294
d2e4a39e 11295 if (*subtype_info == 'L')
4c4b4cd2
PH
11296 {
11297 if (!ada_scan_number (bounds_str, n, &L, &n)
11298 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11299 return raw_type;
11300 if (bounds_str[n] == '_')
11301 n += 2;
0963b4bd 11302 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11303 n += 1;
11304 subtype_info += 1;
11305 }
d2e4a39e 11306 else
4c4b4cd2
PH
11307 {
11308 int ok;
5b4ee69b 11309
4c4b4cd2
PH
11310 strcpy (name_buf + prefix_len, "___L");
11311 L = get_int_var_value (name_buf, &ok);
11312 if (!ok)
11313 {
323e0a4a 11314 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11315 L = 1;
11316 }
11317 }
14f9c5c9 11318
d2e4a39e 11319 if (*subtype_info == 'U')
4c4b4cd2
PH
11320 {
11321 if (!ada_scan_number (bounds_str, n, &U, &n)
11322 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11323 return raw_type;
11324 }
d2e4a39e 11325 else
4c4b4cd2
PH
11326 {
11327 int ok;
5b4ee69b 11328
4c4b4cd2
PH
11329 strcpy (name_buf + prefix_len, "___U");
11330 U = get_int_var_value (name_buf, &ok);
11331 if (!ok)
11332 {
323e0a4a 11333 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11334 U = L;
11335 }
11336 }
14f9c5c9 11337
0c9c3474
SA
11338 type = create_static_range_type (alloc_type_copy (raw_type),
11339 base_type, L, U);
d2e4a39e 11340 TYPE_NAME (type) = name;
14f9c5c9
AS
11341 return type;
11342 }
11343}
11344
4c4b4cd2
PH
11345/* True iff NAME is the name of a range type. */
11346
14f9c5c9 11347int
d2e4a39e 11348ada_is_range_type_name (const char *name)
14f9c5c9
AS
11349{
11350 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11351}
14f9c5c9 11352\f
d2e4a39e 11353
4c4b4cd2
PH
11354 /* Modular types */
11355
11356/* True iff TYPE is an Ada modular type. */
14f9c5c9 11357
14f9c5c9 11358int
d2e4a39e 11359ada_is_modular_type (struct type *type)
14f9c5c9 11360{
18af8284 11361 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11362
11363 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11364 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11365 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11366}
11367
4c4b4cd2
PH
11368/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11369
61ee279c 11370ULONGEST
0056e4d5 11371ada_modulus (struct type *type)
14f9c5c9 11372{
43bbcdc2 11373 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11374}
d2e4a39e 11375\f
f7f9143b
JB
11376
11377/* Ada exception catchpoint support:
11378 ---------------------------------
11379
11380 We support 3 kinds of exception catchpoints:
11381 . catchpoints on Ada exceptions
11382 . catchpoints on unhandled Ada exceptions
11383 . catchpoints on failed assertions
11384
11385 Exceptions raised during failed assertions, or unhandled exceptions
11386 could perfectly be caught with the general catchpoint on Ada exceptions.
11387 However, we can easily differentiate these two special cases, and having
11388 the option to distinguish these two cases from the rest can be useful
11389 to zero-in on certain situations.
11390
11391 Exception catchpoints are a specialized form of breakpoint,
11392 since they rely on inserting breakpoints inside known routines
11393 of the GNAT runtime. The implementation therefore uses a standard
11394 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11395 of breakpoint_ops.
11396
0259addd
JB
11397 Support in the runtime for exception catchpoints have been changed
11398 a few times already, and these changes affect the implementation
11399 of these catchpoints. In order to be able to support several
11400 variants of the runtime, we use a sniffer that will determine
28010a5d 11401 the runtime variant used by the program being debugged. */
f7f9143b 11402
82eacd52
JB
11403/* Ada's standard exceptions.
11404
11405 The Ada 83 standard also defined Numeric_Error. But there so many
11406 situations where it was unclear from the Ada 83 Reference Manual
11407 (RM) whether Constraint_Error or Numeric_Error should be raised,
11408 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11409 Interpretation saying that anytime the RM says that Numeric_Error
11410 should be raised, the implementation may raise Constraint_Error.
11411 Ada 95 went one step further and pretty much removed Numeric_Error
11412 from the list of standard exceptions (it made it a renaming of
11413 Constraint_Error, to help preserve compatibility when compiling
11414 an Ada83 compiler). As such, we do not include Numeric_Error from
11415 this list of standard exceptions. */
3d0b0fa3
JB
11416
11417static char *standard_exc[] = {
11418 "constraint_error",
11419 "program_error",
11420 "storage_error",
11421 "tasking_error"
11422};
11423
0259addd
JB
11424typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11425
11426/* A structure that describes how to support exception catchpoints
11427 for a given executable. */
11428
11429struct exception_support_info
11430{
11431 /* The name of the symbol to break on in order to insert
11432 a catchpoint on exceptions. */
11433 const char *catch_exception_sym;
11434
11435 /* The name of the symbol to break on in order to insert
11436 a catchpoint on unhandled exceptions. */
11437 const char *catch_exception_unhandled_sym;
11438
11439 /* The name of the symbol to break on in order to insert
11440 a catchpoint on failed assertions. */
11441 const char *catch_assert_sym;
11442
11443 /* Assuming that the inferior just triggered an unhandled exception
11444 catchpoint, this function is responsible for returning the address
11445 in inferior memory where the name of that exception is stored.
11446 Return zero if the address could not be computed. */
11447 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11448};
11449
11450static CORE_ADDR ada_unhandled_exception_name_addr (void);
11451static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11452
11453/* The following exception support info structure describes how to
11454 implement exception catchpoints with the latest version of the
11455 Ada runtime (as of 2007-03-06). */
11456
11457static const struct exception_support_info default_exception_support_info =
11458{
11459 "__gnat_debug_raise_exception", /* catch_exception_sym */
11460 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11461 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11462 ada_unhandled_exception_name_addr
11463};
11464
11465/* The following exception support info structure describes how to
11466 implement exception catchpoints with a slightly older version
11467 of the Ada runtime. */
11468
11469static const struct exception_support_info exception_support_info_fallback =
11470{
11471 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11472 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11473 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11474 ada_unhandled_exception_name_addr_from_raise
11475};
11476
f17011e0
JB
11477/* Return nonzero if we can detect the exception support routines
11478 described in EINFO.
11479
11480 This function errors out if an abnormal situation is detected
11481 (for instance, if we find the exception support routines, but
11482 that support is found to be incomplete). */
11483
11484static int
11485ada_has_this_exception_support (const struct exception_support_info *einfo)
11486{
11487 struct symbol *sym;
11488
11489 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11490 that should be compiled with debugging information. As a result, we
11491 expect to find that symbol in the symtabs. */
11492
11493 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11494 if (sym == NULL)
a6af7abe
JB
11495 {
11496 /* Perhaps we did not find our symbol because the Ada runtime was
11497 compiled without debugging info, or simply stripped of it.
11498 It happens on some GNU/Linux distributions for instance, where
11499 users have to install a separate debug package in order to get
11500 the runtime's debugging info. In that situation, let the user
11501 know why we cannot insert an Ada exception catchpoint.
11502
11503 Note: Just for the purpose of inserting our Ada exception
11504 catchpoint, we could rely purely on the associated minimal symbol.
11505 But we would be operating in degraded mode anyway, since we are
11506 still lacking the debugging info needed later on to extract
11507 the name of the exception being raised (this name is printed in
11508 the catchpoint message, and is also used when trying to catch
11509 a specific exception). We do not handle this case for now. */
3b7344d5 11510 struct bound_minimal_symbol msym
1c8e84b0
JB
11511 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11512
3b7344d5 11513 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
11514 error (_("Your Ada runtime appears to be missing some debugging "
11515 "information.\nCannot insert Ada exception catchpoint "
11516 "in this configuration."));
11517
11518 return 0;
11519 }
f17011e0
JB
11520
11521 /* Make sure that the symbol we found corresponds to a function. */
11522
11523 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11524 error (_("Symbol \"%s\" is not a function (class = %d)"),
11525 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11526
11527 return 1;
11528}
11529
0259addd
JB
11530/* Inspect the Ada runtime and determine which exception info structure
11531 should be used to provide support for exception catchpoints.
11532
3eecfa55
JB
11533 This function will always set the per-inferior exception_info,
11534 or raise an error. */
0259addd
JB
11535
11536static void
11537ada_exception_support_info_sniffer (void)
11538{
3eecfa55 11539 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
11540
11541 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 11542 if (data->exception_info != NULL)
0259addd
JB
11543 return;
11544
11545 /* Check the latest (default) exception support info. */
f17011e0 11546 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 11547 {
3eecfa55 11548 data->exception_info = &default_exception_support_info;
0259addd
JB
11549 return;
11550 }
11551
11552 /* Try our fallback exception suport info. */
f17011e0 11553 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 11554 {
3eecfa55 11555 data->exception_info = &exception_support_info_fallback;
0259addd
JB
11556 return;
11557 }
11558
11559 /* Sometimes, it is normal for us to not be able to find the routine
11560 we are looking for. This happens when the program is linked with
11561 the shared version of the GNAT runtime, and the program has not been
11562 started yet. Inform the user of these two possible causes if
11563 applicable. */
11564
ccefe4c4 11565 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
11566 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11567
11568 /* If the symbol does not exist, then check that the program is
11569 already started, to make sure that shared libraries have been
11570 loaded. If it is not started, this may mean that the symbol is
11571 in a shared library. */
11572
11573 if (ptid_get_pid (inferior_ptid) == 0)
11574 error (_("Unable to insert catchpoint. Try to start the program first."));
11575
11576 /* At this point, we know that we are debugging an Ada program and
11577 that the inferior has been started, but we still are not able to
0963b4bd 11578 find the run-time symbols. That can mean that we are in
0259addd
JB
11579 configurable run time mode, or that a-except as been optimized
11580 out by the linker... In any case, at this point it is not worth
11581 supporting this feature. */
11582
7dda8cff 11583 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
11584}
11585
f7f9143b
JB
11586/* True iff FRAME is very likely to be that of a function that is
11587 part of the runtime system. This is all very heuristic, but is
11588 intended to be used as advice as to what frames are uninteresting
11589 to most users. */
11590
11591static int
11592is_known_support_routine (struct frame_info *frame)
11593{
4ed6b5be 11594 struct symtab_and_line sal;
55b87a52 11595 char *func_name;
692465f1 11596 enum language func_lang;
f7f9143b 11597 int i;
f35a17b5 11598 const char *fullname;
f7f9143b 11599
4ed6b5be
JB
11600 /* If this code does not have any debugging information (no symtab),
11601 This cannot be any user code. */
f7f9143b 11602
4ed6b5be 11603 find_frame_sal (frame, &sal);
f7f9143b
JB
11604 if (sal.symtab == NULL)
11605 return 1;
11606
4ed6b5be
JB
11607 /* If there is a symtab, but the associated source file cannot be
11608 located, then assume this is not user code: Selecting a frame
11609 for which we cannot display the code would not be very helpful
11610 for the user. This should also take care of case such as VxWorks
11611 where the kernel has some debugging info provided for a few units. */
f7f9143b 11612
f35a17b5
JK
11613 fullname = symtab_to_fullname (sal.symtab);
11614 if (access (fullname, R_OK) != 0)
f7f9143b
JB
11615 return 1;
11616
4ed6b5be
JB
11617 /* Check the unit filename againt the Ada runtime file naming.
11618 We also check the name of the objfile against the name of some
11619 known system libraries that sometimes come with debugging info
11620 too. */
11621
f7f9143b
JB
11622 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11623 {
11624 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 11625 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 11626 return 1;
eb822aa6
DE
11627 if (SYMTAB_OBJFILE (sal.symtab) != NULL
11628 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
4ed6b5be 11629 return 1;
f7f9143b
JB
11630 }
11631
4ed6b5be 11632 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 11633
e9e07ba6 11634 find_frame_funname (frame, &func_name, &func_lang, NULL);
f7f9143b
JB
11635 if (func_name == NULL)
11636 return 1;
11637
11638 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11639 {
11640 re_comp (known_auxiliary_function_name_patterns[i]);
11641 if (re_exec (func_name))
55b87a52
KS
11642 {
11643 xfree (func_name);
11644 return 1;
11645 }
f7f9143b
JB
11646 }
11647
55b87a52 11648 xfree (func_name);
f7f9143b
JB
11649 return 0;
11650}
11651
11652/* Find the first frame that contains debugging information and that is not
11653 part of the Ada run-time, starting from FI and moving upward. */
11654
0ef643c8 11655void
f7f9143b
JB
11656ada_find_printable_frame (struct frame_info *fi)
11657{
11658 for (; fi != NULL; fi = get_prev_frame (fi))
11659 {
11660 if (!is_known_support_routine (fi))
11661 {
11662 select_frame (fi);
11663 break;
11664 }
11665 }
11666
11667}
11668
11669/* Assuming that the inferior just triggered an unhandled exception
11670 catchpoint, return the address in inferior memory where the name
11671 of the exception is stored.
11672
11673 Return zero if the address could not be computed. */
11674
11675static CORE_ADDR
11676ada_unhandled_exception_name_addr (void)
0259addd
JB
11677{
11678 return parse_and_eval_address ("e.full_name");
11679}
11680
11681/* Same as ada_unhandled_exception_name_addr, except that this function
11682 should be used when the inferior uses an older version of the runtime,
11683 where the exception name needs to be extracted from a specific frame
11684 several frames up in the callstack. */
11685
11686static CORE_ADDR
11687ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
11688{
11689 int frame_level;
11690 struct frame_info *fi;
3eecfa55 11691 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
55b87a52 11692 struct cleanup *old_chain;
f7f9143b
JB
11693
11694 /* To determine the name of this exception, we need to select
11695 the frame corresponding to RAISE_SYM_NAME. This frame is
11696 at least 3 levels up, so we simply skip the first 3 frames
11697 without checking the name of their associated function. */
11698 fi = get_current_frame ();
11699 for (frame_level = 0; frame_level < 3; frame_level += 1)
11700 if (fi != NULL)
11701 fi = get_prev_frame (fi);
11702
55b87a52 11703 old_chain = make_cleanup (null_cleanup, NULL);
f7f9143b
JB
11704 while (fi != NULL)
11705 {
55b87a52 11706 char *func_name;
692465f1
JB
11707 enum language func_lang;
11708
e9e07ba6 11709 find_frame_funname (fi, &func_name, &func_lang, NULL);
55b87a52
KS
11710 if (func_name != NULL)
11711 {
11712 make_cleanup (xfree, func_name);
11713
11714 if (strcmp (func_name,
11715 data->exception_info->catch_exception_sym) == 0)
11716 break; /* We found the frame we were looking for... */
11717 fi = get_prev_frame (fi);
11718 }
f7f9143b 11719 }
55b87a52 11720 do_cleanups (old_chain);
f7f9143b
JB
11721
11722 if (fi == NULL)
11723 return 0;
11724
11725 select_frame (fi);
11726 return parse_and_eval_address ("id.full_name");
11727}
11728
11729/* Assuming the inferior just triggered an Ada exception catchpoint
11730 (of any type), return the address in inferior memory where the name
11731 of the exception is stored, if applicable.
11732
11733 Return zero if the address could not be computed, or if not relevant. */
11734
11735static CORE_ADDR
761269c8 11736ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11737 struct breakpoint *b)
11738{
3eecfa55
JB
11739 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11740
f7f9143b
JB
11741 switch (ex)
11742 {
761269c8 11743 case ada_catch_exception:
f7f9143b
JB
11744 return (parse_and_eval_address ("e.full_name"));
11745 break;
11746
761269c8 11747 case ada_catch_exception_unhandled:
3eecfa55 11748 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
11749 break;
11750
761269c8 11751 case ada_catch_assert:
f7f9143b
JB
11752 return 0; /* Exception name is not relevant in this case. */
11753 break;
11754
11755 default:
11756 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11757 break;
11758 }
11759
11760 return 0; /* Should never be reached. */
11761}
11762
11763/* Same as ada_exception_name_addr_1, except that it intercepts and contains
11764 any error that ada_exception_name_addr_1 might cause to be thrown.
11765 When an error is intercepted, a warning with the error message is printed,
11766 and zero is returned. */
11767
11768static CORE_ADDR
761269c8 11769ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11770 struct breakpoint *b)
11771{
bfd189b1 11772 volatile struct gdb_exception e;
f7f9143b
JB
11773 CORE_ADDR result = 0;
11774
11775 TRY_CATCH (e, RETURN_MASK_ERROR)
11776 {
11777 result = ada_exception_name_addr_1 (ex, b);
11778 }
11779
11780 if (e.reason < 0)
11781 {
11782 warning (_("failed to get exception name: %s"), e.message);
11783 return 0;
11784 }
11785
11786 return result;
11787}
11788
28010a5d
PA
11789static char *ada_exception_catchpoint_cond_string (const char *excep_string);
11790
11791/* Ada catchpoints.
11792
11793 In the case of catchpoints on Ada exceptions, the catchpoint will
11794 stop the target on every exception the program throws. When a user
11795 specifies the name of a specific exception, we translate this
11796 request into a condition expression (in text form), and then parse
11797 it into an expression stored in each of the catchpoint's locations.
11798 We then use this condition to check whether the exception that was
11799 raised is the one the user is interested in. If not, then the
11800 target is resumed again. We store the name of the requested
11801 exception, in order to be able to re-set the condition expression
11802 when symbols change. */
11803
11804/* An instance of this type is used to represent an Ada catchpoint
11805 breakpoint location. It includes a "struct bp_location" as a kind
11806 of base class; users downcast to "struct bp_location *" when
11807 needed. */
11808
11809struct ada_catchpoint_location
11810{
11811 /* The base class. */
11812 struct bp_location base;
11813
11814 /* The condition that checks whether the exception that was raised
11815 is the specific exception the user specified on catchpoint
11816 creation. */
11817 struct expression *excep_cond_expr;
11818};
11819
11820/* Implement the DTOR method in the bp_location_ops structure for all
11821 Ada exception catchpoint kinds. */
11822
11823static void
11824ada_catchpoint_location_dtor (struct bp_location *bl)
11825{
11826 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
11827
11828 xfree (al->excep_cond_expr);
11829}
11830
11831/* The vtable to be used in Ada catchpoint locations. */
11832
11833static const struct bp_location_ops ada_catchpoint_location_ops =
11834{
11835 ada_catchpoint_location_dtor
11836};
11837
11838/* An instance of this type is used to represent an Ada catchpoint.
11839 It includes a "struct breakpoint" as a kind of base class; users
11840 downcast to "struct breakpoint *" when needed. */
11841
11842struct ada_catchpoint
11843{
11844 /* The base class. */
11845 struct breakpoint base;
11846
11847 /* The name of the specific exception the user specified. */
11848 char *excep_string;
11849};
11850
11851/* Parse the exception condition string in the context of each of the
11852 catchpoint's locations, and store them for later evaluation. */
11853
11854static void
11855create_excep_cond_exprs (struct ada_catchpoint *c)
11856{
11857 struct cleanup *old_chain;
11858 struct bp_location *bl;
11859 char *cond_string;
11860
11861 /* Nothing to do if there's no specific exception to catch. */
11862 if (c->excep_string == NULL)
11863 return;
11864
11865 /* Same if there are no locations... */
11866 if (c->base.loc == NULL)
11867 return;
11868
11869 /* Compute the condition expression in text form, from the specific
11870 expection we want to catch. */
11871 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
11872 old_chain = make_cleanup (xfree, cond_string);
11873
11874 /* Iterate over all the catchpoint's locations, and parse an
11875 expression for each. */
11876 for (bl = c->base.loc; bl != NULL; bl = bl->next)
11877 {
11878 struct ada_catchpoint_location *ada_loc
11879 = (struct ada_catchpoint_location *) bl;
11880 struct expression *exp = NULL;
11881
11882 if (!bl->shlib_disabled)
11883 {
11884 volatile struct gdb_exception e;
bbc13ae3 11885 const char *s;
28010a5d
PA
11886
11887 s = cond_string;
11888 TRY_CATCH (e, RETURN_MASK_ERROR)
11889 {
1bb9788d
TT
11890 exp = parse_exp_1 (&s, bl->address,
11891 block_for_pc (bl->address), 0);
28010a5d
PA
11892 }
11893 if (e.reason < 0)
849f2b52
JB
11894 {
11895 warning (_("failed to reevaluate internal exception condition "
11896 "for catchpoint %d: %s"),
11897 c->base.number, e.message);
11898 /* There is a bug in GCC on sparc-solaris when building with
11899 optimization which causes EXP to change unexpectedly
11900 (http://gcc.gnu.org/bugzilla/show_bug.cgi?id=56982).
11901 The problem should be fixed starting with GCC 4.9.
11902 In the meantime, work around it by forcing EXP back
11903 to NULL. */
11904 exp = NULL;
11905 }
28010a5d
PA
11906 }
11907
11908 ada_loc->excep_cond_expr = exp;
11909 }
11910
11911 do_cleanups (old_chain);
11912}
11913
11914/* Implement the DTOR method in the breakpoint_ops structure for all
11915 exception catchpoint kinds. */
11916
11917static void
761269c8 11918dtor_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
11919{
11920 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11921
11922 xfree (c->excep_string);
348d480f 11923
2060206e 11924 bkpt_breakpoint_ops.dtor (b);
28010a5d
PA
11925}
11926
11927/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11928 structure for all exception catchpoint kinds. */
11929
11930static struct bp_location *
761269c8 11931allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
11932 struct breakpoint *self)
11933{
11934 struct ada_catchpoint_location *loc;
11935
11936 loc = XNEW (struct ada_catchpoint_location);
11937 init_bp_location (&loc->base, &ada_catchpoint_location_ops, self);
11938 loc->excep_cond_expr = NULL;
11939 return &loc->base;
11940}
11941
11942/* Implement the RE_SET method in the breakpoint_ops structure for all
11943 exception catchpoint kinds. */
11944
11945static void
761269c8 11946re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
11947{
11948 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11949
11950 /* Call the base class's method. This updates the catchpoint's
11951 locations. */
2060206e 11952 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
11953
11954 /* Reparse the exception conditional expressions. One for each
11955 location. */
11956 create_excep_cond_exprs (c);
11957}
11958
11959/* Returns true if we should stop for this breakpoint hit. If the
11960 user specified a specific exception, we only want to cause a stop
11961 if the program thrown that exception. */
11962
11963static int
11964should_stop_exception (const struct bp_location *bl)
11965{
11966 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11967 const struct ada_catchpoint_location *ada_loc
11968 = (const struct ada_catchpoint_location *) bl;
11969 volatile struct gdb_exception ex;
11970 int stop;
11971
11972 /* With no specific exception, should always stop. */
11973 if (c->excep_string == NULL)
11974 return 1;
11975
11976 if (ada_loc->excep_cond_expr == NULL)
11977 {
11978 /* We will have a NULL expression if back when we were creating
11979 the expressions, this location's had failed to parse. */
11980 return 1;
11981 }
11982
11983 stop = 1;
11984 TRY_CATCH (ex, RETURN_MASK_ALL)
11985 {
11986 struct value *mark;
11987
11988 mark = value_mark ();
11989 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr));
11990 value_free_to_mark (mark);
11991 }
11992 if (ex.reason < 0)
11993 exception_fprintf (gdb_stderr, ex,
11994 _("Error in testing exception condition:\n"));
11995 return stop;
11996}
11997
11998/* Implement the CHECK_STATUS method in the breakpoint_ops structure
11999 for all exception catchpoint kinds. */
12000
12001static void
761269c8 12002check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
12003{
12004 bs->stop = should_stop_exception (bs->bp_location_at);
12005}
12006
f7f9143b
JB
12007/* Implement the PRINT_IT method in the breakpoint_ops structure
12008 for all exception catchpoint kinds. */
12009
12010static enum print_stop_action
761269c8 12011print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 12012{
79a45e25 12013 struct ui_out *uiout = current_uiout;
348d480f
PA
12014 struct breakpoint *b = bs->breakpoint_at;
12015
956a9fb9 12016 annotate_catchpoint (b->number);
f7f9143b 12017
956a9fb9 12018 if (ui_out_is_mi_like_p (uiout))
f7f9143b 12019 {
956a9fb9
JB
12020 ui_out_field_string (uiout, "reason",
12021 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12022 ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition));
f7f9143b
JB
12023 }
12024
00eb2c4a
JB
12025 ui_out_text (uiout,
12026 b->disposition == disp_del ? "\nTemporary catchpoint "
12027 : "\nCatchpoint ");
956a9fb9
JB
12028 ui_out_field_int (uiout, "bkptno", b->number);
12029 ui_out_text (uiout, ", ");
f7f9143b 12030
f7f9143b
JB
12031 switch (ex)
12032 {
761269c8
JB
12033 case ada_catch_exception:
12034 case ada_catch_exception_unhandled:
956a9fb9
JB
12035 {
12036 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12037 char exception_name[256];
12038
12039 if (addr != 0)
12040 {
c714b426
PA
12041 read_memory (addr, (gdb_byte *) exception_name,
12042 sizeof (exception_name) - 1);
956a9fb9
JB
12043 exception_name [sizeof (exception_name) - 1] = '\0';
12044 }
12045 else
12046 {
12047 /* For some reason, we were unable to read the exception
12048 name. This could happen if the Runtime was compiled
12049 without debugging info, for instance. In that case,
12050 just replace the exception name by the generic string
12051 "exception" - it will read as "an exception" in the
12052 notification we are about to print. */
967cff16 12053 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
12054 }
12055 /* In the case of unhandled exception breakpoints, we print
12056 the exception name as "unhandled EXCEPTION_NAME", to make
12057 it clearer to the user which kind of catchpoint just got
12058 hit. We used ui_out_text to make sure that this extra
12059 info does not pollute the exception name in the MI case. */
761269c8 12060 if (ex == ada_catch_exception_unhandled)
956a9fb9
JB
12061 ui_out_text (uiout, "unhandled ");
12062 ui_out_field_string (uiout, "exception-name", exception_name);
12063 }
12064 break;
761269c8 12065 case ada_catch_assert:
956a9fb9
JB
12066 /* In this case, the name of the exception is not really
12067 important. Just print "failed assertion" to make it clearer
12068 that his program just hit an assertion-failure catchpoint.
12069 We used ui_out_text because this info does not belong in
12070 the MI output. */
12071 ui_out_text (uiout, "failed assertion");
12072 break;
f7f9143b 12073 }
956a9fb9
JB
12074 ui_out_text (uiout, " at ");
12075 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
12076
12077 return PRINT_SRC_AND_LOC;
12078}
12079
12080/* Implement the PRINT_ONE method in the breakpoint_ops structure
12081 for all exception catchpoint kinds. */
12082
12083static void
761269c8 12084print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 12085 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12086{
79a45e25 12087 struct ui_out *uiout = current_uiout;
28010a5d 12088 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
12089 struct value_print_options opts;
12090
12091 get_user_print_options (&opts);
12092 if (opts.addressprint)
f7f9143b
JB
12093 {
12094 annotate_field (4);
5af949e3 12095 ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
12096 }
12097
12098 annotate_field (5);
a6d9a66e 12099 *last_loc = b->loc;
f7f9143b
JB
12100 switch (ex)
12101 {
761269c8 12102 case ada_catch_exception:
28010a5d 12103 if (c->excep_string != NULL)
f7f9143b 12104 {
28010a5d
PA
12105 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12106
f7f9143b
JB
12107 ui_out_field_string (uiout, "what", msg);
12108 xfree (msg);
12109 }
12110 else
12111 ui_out_field_string (uiout, "what", "all Ada exceptions");
12112
12113 break;
12114
761269c8 12115 case ada_catch_exception_unhandled:
f7f9143b
JB
12116 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
12117 break;
12118
761269c8 12119 case ada_catch_assert:
f7f9143b
JB
12120 ui_out_field_string (uiout, "what", "failed Ada assertions");
12121 break;
12122
12123 default:
12124 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12125 break;
12126 }
12127}
12128
12129/* Implement the PRINT_MENTION method in the breakpoint_ops structure
12130 for all exception catchpoint kinds. */
12131
12132static void
761269c8 12133print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12134 struct breakpoint *b)
12135{
28010a5d 12136 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 12137 struct ui_out *uiout = current_uiout;
28010a5d 12138
00eb2c4a
JB
12139 ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ")
12140 : _("Catchpoint "));
12141 ui_out_field_int (uiout, "bkptno", b->number);
12142 ui_out_text (uiout, ": ");
12143
f7f9143b
JB
12144 switch (ex)
12145 {
761269c8 12146 case ada_catch_exception:
28010a5d 12147 if (c->excep_string != NULL)
00eb2c4a
JB
12148 {
12149 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12150 struct cleanup *old_chain = make_cleanup (xfree, info);
12151
12152 ui_out_text (uiout, info);
12153 do_cleanups (old_chain);
12154 }
f7f9143b 12155 else
00eb2c4a 12156 ui_out_text (uiout, _("all Ada exceptions"));
f7f9143b
JB
12157 break;
12158
761269c8 12159 case ada_catch_exception_unhandled:
00eb2c4a 12160 ui_out_text (uiout, _("unhandled Ada exceptions"));
f7f9143b
JB
12161 break;
12162
761269c8 12163 case ada_catch_assert:
00eb2c4a 12164 ui_out_text (uiout, _("failed Ada assertions"));
f7f9143b
JB
12165 break;
12166
12167 default:
12168 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12169 break;
12170 }
12171}
12172
6149aea9
PA
12173/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12174 for all exception catchpoint kinds. */
12175
12176static void
761269c8 12177print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
12178 struct breakpoint *b, struct ui_file *fp)
12179{
28010a5d
PA
12180 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12181
6149aea9
PA
12182 switch (ex)
12183 {
761269c8 12184 case ada_catch_exception:
6149aea9 12185 fprintf_filtered (fp, "catch exception");
28010a5d
PA
12186 if (c->excep_string != NULL)
12187 fprintf_filtered (fp, " %s", c->excep_string);
6149aea9
PA
12188 break;
12189
761269c8 12190 case ada_catch_exception_unhandled:
78076abc 12191 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12192 break;
12193
761269c8 12194 case ada_catch_assert:
6149aea9
PA
12195 fprintf_filtered (fp, "catch assert");
12196 break;
12197
12198 default:
12199 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12200 }
d9b3f62e 12201 print_recreate_thread (b, fp);
6149aea9
PA
12202}
12203
f7f9143b
JB
12204/* Virtual table for "catch exception" breakpoints. */
12205
28010a5d
PA
12206static void
12207dtor_catch_exception (struct breakpoint *b)
12208{
761269c8 12209 dtor_exception (ada_catch_exception, b);
28010a5d
PA
12210}
12211
12212static struct bp_location *
12213allocate_location_catch_exception (struct breakpoint *self)
12214{
761269c8 12215 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12216}
12217
12218static void
12219re_set_catch_exception (struct breakpoint *b)
12220{
761269c8 12221 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12222}
12223
12224static void
12225check_status_catch_exception (bpstat bs)
12226{
761269c8 12227 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12228}
12229
f7f9143b 12230static enum print_stop_action
348d480f 12231print_it_catch_exception (bpstat bs)
f7f9143b 12232{
761269c8 12233 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12234}
12235
12236static void
a6d9a66e 12237print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12238{
761269c8 12239 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12240}
12241
12242static void
12243print_mention_catch_exception (struct breakpoint *b)
12244{
761269c8 12245 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12246}
12247
6149aea9
PA
12248static void
12249print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12250{
761269c8 12251 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12252}
12253
2060206e 12254static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12255
12256/* Virtual table for "catch exception unhandled" breakpoints. */
12257
28010a5d
PA
12258static void
12259dtor_catch_exception_unhandled (struct breakpoint *b)
12260{
761269c8 12261 dtor_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12262}
12263
12264static struct bp_location *
12265allocate_location_catch_exception_unhandled (struct breakpoint *self)
12266{
761269c8 12267 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12268}
12269
12270static void
12271re_set_catch_exception_unhandled (struct breakpoint *b)
12272{
761269c8 12273 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12274}
12275
12276static void
12277check_status_catch_exception_unhandled (bpstat bs)
12278{
761269c8 12279 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12280}
12281
f7f9143b 12282static enum print_stop_action
348d480f 12283print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12284{
761269c8 12285 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12286}
12287
12288static void
a6d9a66e
UW
12289print_one_catch_exception_unhandled (struct breakpoint *b,
12290 struct bp_location **last_loc)
f7f9143b 12291{
761269c8 12292 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12293}
12294
12295static void
12296print_mention_catch_exception_unhandled (struct breakpoint *b)
12297{
761269c8 12298 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12299}
12300
6149aea9
PA
12301static void
12302print_recreate_catch_exception_unhandled (struct breakpoint *b,
12303 struct ui_file *fp)
12304{
761269c8 12305 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12306}
12307
2060206e 12308static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12309
12310/* Virtual table for "catch assert" breakpoints. */
12311
28010a5d
PA
12312static void
12313dtor_catch_assert (struct breakpoint *b)
12314{
761269c8 12315 dtor_exception (ada_catch_assert, b);
28010a5d
PA
12316}
12317
12318static struct bp_location *
12319allocate_location_catch_assert (struct breakpoint *self)
12320{
761269c8 12321 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12322}
12323
12324static void
12325re_set_catch_assert (struct breakpoint *b)
12326{
761269c8 12327 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12328}
12329
12330static void
12331check_status_catch_assert (bpstat bs)
12332{
761269c8 12333 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12334}
12335
f7f9143b 12336static enum print_stop_action
348d480f 12337print_it_catch_assert (bpstat bs)
f7f9143b 12338{
761269c8 12339 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12340}
12341
12342static void
a6d9a66e 12343print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12344{
761269c8 12345 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
12346}
12347
12348static void
12349print_mention_catch_assert (struct breakpoint *b)
12350{
761269c8 12351 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
12352}
12353
6149aea9
PA
12354static void
12355print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12356{
761269c8 12357 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
12358}
12359
2060206e 12360static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 12361
f7f9143b
JB
12362/* Return a newly allocated copy of the first space-separated token
12363 in ARGSP, and then adjust ARGSP to point immediately after that
12364 token.
12365
12366 Return NULL if ARGPS does not contain any more tokens. */
12367
12368static char *
12369ada_get_next_arg (char **argsp)
12370{
12371 char *args = *argsp;
12372 char *end;
12373 char *result;
12374
0fcd72ba 12375 args = skip_spaces (args);
f7f9143b
JB
12376 if (args[0] == '\0')
12377 return NULL; /* No more arguments. */
12378
12379 /* Find the end of the current argument. */
12380
0fcd72ba 12381 end = skip_to_space (args);
f7f9143b
JB
12382
12383 /* Adjust ARGSP to point to the start of the next argument. */
12384
12385 *argsp = end;
12386
12387 /* Make a copy of the current argument and return it. */
12388
12389 result = xmalloc (end - args + 1);
12390 strncpy (result, args, end - args);
12391 result[end - args] = '\0';
12392
12393 return result;
12394}
12395
12396/* Split the arguments specified in a "catch exception" command.
12397 Set EX to the appropriate catchpoint type.
28010a5d 12398 Set EXCEP_STRING to the name of the specific exception if
5845583d
JB
12399 specified by the user.
12400 If a condition is found at the end of the arguments, the condition
12401 expression is stored in COND_STRING (memory must be deallocated
12402 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
12403
12404static void
12405catch_ada_exception_command_split (char *args,
761269c8 12406 enum ada_exception_catchpoint_kind *ex,
5845583d
JB
12407 char **excep_string,
12408 char **cond_string)
f7f9143b
JB
12409{
12410 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
12411 char *exception_name;
5845583d 12412 char *cond = NULL;
f7f9143b
JB
12413
12414 exception_name = ada_get_next_arg (&args);
5845583d
JB
12415 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
12416 {
12417 /* This is not an exception name; this is the start of a condition
12418 expression for a catchpoint on all exceptions. So, "un-get"
12419 this token, and set exception_name to NULL. */
12420 xfree (exception_name);
12421 exception_name = NULL;
12422 args -= 2;
12423 }
f7f9143b
JB
12424 make_cleanup (xfree, exception_name);
12425
5845583d 12426 /* Check to see if we have a condition. */
f7f9143b 12427
0fcd72ba 12428 args = skip_spaces (args);
5845583d
JB
12429 if (strncmp (args, "if", 2) == 0
12430 && (isspace (args[2]) || args[2] == '\0'))
12431 {
12432 args += 2;
12433 args = skip_spaces (args);
12434
12435 if (args[0] == '\0')
12436 error (_("Condition missing after `if' keyword"));
12437 cond = xstrdup (args);
12438 make_cleanup (xfree, cond);
12439
12440 args += strlen (args);
12441 }
12442
12443 /* Check that we do not have any more arguments. Anything else
12444 is unexpected. */
f7f9143b
JB
12445
12446 if (args[0] != '\0')
12447 error (_("Junk at end of expression"));
12448
12449 discard_cleanups (old_chain);
12450
12451 if (exception_name == NULL)
12452 {
12453 /* Catch all exceptions. */
761269c8 12454 *ex = ada_catch_exception;
28010a5d 12455 *excep_string = NULL;
f7f9143b
JB
12456 }
12457 else if (strcmp (exception_name, "unhandled") == 0)
12458 {
12459 /* Catch unhandled exceptions. */
761269c8 12460 *ex = ada_catch_exception_unhandled;
28010a5d 12461 *excep_string = NULL;
f7f9143b
JB
12462 }
12463 else
12464 {
12465 /* Catch a specific exception. */
761269c8 12466 *ex = ada_catch_exception;
28010a5d 12467 *excep_string = exception_name;
f7f9143b 12468 }
5845583d 12469 *cond_string = cond;
f7f9143b
JB
12470}
12471
12472/* Return the name of the symbol on which we should break in order to
12473 implement a catchpoint of the EX kind. */
12474
12475static const char *
761269c8 12476ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 12477{
3eecfa55
JB
12478 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12479
12480 gdb_assert (data->exception_info != NULL);
0259addd 12481
f7f9143b
JB
12482 switch (ex)
12483 {
761269c8 12484 case ada_catch_exception:
3eecfa55 12485 return (data->exception_info->catch_exception_sym);
f7f9143b 12486 break;
761269c8 12487 case ada_catch_exception_unhandled:
3eecfa55 12488 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 12489 break;
761269c8 12490 case ada_catch_assert:
3eecfa55 12491 return (data->exception_info->catch_assert_sym);
f7f9143b
JB
12492 break;
12493 default:
12494 internal_error (__FILE__, __LINE__,
12495 _("unexpected catchpoint kind (%d)"), ex);
12496 }
12497}
12498
12499/* Return the breakpoint ops "virtual table" used for catchpoints
12500 of the EX kind. */
12501
c0a91b2b 12502static const struct breakpoint_ops *
761269c8 12503ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
12504{
12505 switch (ex)
12506 {
761269c8 12507 case ada_catch_exception:
f7f9143b
JB
12508 return (&catch_exception_breakpoint_ops);
12509 break;
761269c8 12510 case ada_catch_exception_unhandled:
f7f9143b
JB
12511 return (&catch_exception_unhandled_breakpoint_ops);
12512 break;
761269c8 12513 case ada_catch_assert:
f7f9143b
JB
12514 return (&catch_assert_breakpoint_ops);
12515 break;
12516 default:
12517 internal_error (__FILE__, __LINE__,
12518 _("unexpected catchpoint kind (%d)"), ex);
12519 }
12520}
12521
12522/* Return the condition that will be used to match the current exception
12523 being raised with the exception that the user wants to catch. This
12524 assumes that this condition is used when the inferior just triggered
12525 an exception catchpoint.
12526
12527 The string returned is a newly allocated string that needs to be
12528 deallocated later. */
12529
12530static char *
28010a5d 12531ada_exception_catchpoint_cond_string (const char *excep_string)
f7f9143b 12532{
3d0b0fa3
JB
12533 int i;
12534
0963b4bd 12535 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 12536 runtime units that have been compiled without debugging info; if
28010a5d 12537 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
12538 exception (e.g. "constraint_error") then, during the evaluation
12539 of the condition expression, the symbol lookup on this name would
0963b4bd 12540 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
12541 may then be set only on user-defined exceptions which have the
12542 same not-fully-qualified name (e.g. my_package.constraint_error).
12543
12544 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 12545 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
12546 exception constraint_error" is rewritten into "catch exception
12547 standard.constraint_error".
12548
12549 If an exception named contraint_error is defined in another package of
12550 the inferior program, then the only way to specify this exception as a
12551 breakpoint condition is to use its fully-qualified named:
12552 e.g. my_package.constraint_error. */
12553
12554 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12555 {
28010a5d 12556 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3
JB
12557 {
12558 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
28010a5d 12559 excep_string);
3d0b0fa3
JB
12560 }
12561 }
28010a5d 12562 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
f7f9143b
JB
12563}
12564
12565/* Return the symtab_and_line that should be used to insert an exception
12566 catchpoint of the TYPE kind.
12567
28010a5d
PA
12568 EXCEP_STRING should contain the name of a specific exception that
12569 the catchpoint should catch, or NULL otherwise.
f7f9143b 12570
28010a5d
PA
12571 ADDR_STRING returns the name of the function where the real
12572 breakpoint that implements the catchpoints is set, depending on the
12573 type of catchpoint we need to create. */
f7f9143b
JB
12574
12575static struct symtab_and_line
761269c8 12576ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
c0a91b2b 12577 char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
12578{
12579 const char *sym_name;
12580 struct symbol *sym;
f7f9143b 12581
0259addd
JB
12582 /* First, find out which exception support info to use. */
12583 ada_exception_support_info_sniffer ();
12584
12585 /* Then lookup the function on which we will break in order to catch
f7f9143b 12586 the Ada exceptions requested by the user. */
f7f9143b
JB
12587 sym_name = ada_exception_sym_name (ex);
12588 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12589
f17011e0
JB
12590 /* We can assume that SYM is not NULL at this stage. If the symbol
12591 did not exist, ada_exception_support_info_sniffer would have
12592 raised an exception.
f7f9143b 12593
f17011e0
JB
12594 Also, ada_exception_support_info_sniffer should have already
12595 verified that SYM is a function symbol. */
12596 gdb_assert (sym != NULL);
12597 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
12598
12599 /* Set ADDR_STRING. */
f7f9143b
JB
12600 *addr_string = xstrdup (sym_name);
12601
f7f9143b 12602 /* Set OPS. */
4b9eee8c 12603 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 12604
f17011e0 12605 return find_function_start_sal (sym, 1);
f7f9143b
JB
12606}
12607
b4a5b78b 12608/* Create an Ada exception catchpoint.
f7f9143b 12609
b4a5b78b 12610 EX_KIND is the kind of exception catchpoint to be created.
5845583d 12611
2df4d1d5
JB
12612 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
12613 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12614 of the exception to which this catchpoint applies. When not NULL,
12615 the string must be allocated on the heap, and its deallocation
12616 is no longer the responsibility of the caller.
12617
12618 COND_STRING, if not NULL, is the catchpoint condition. This string
12619 must be allocated on the heap, and its deallocation is no longer
12620 the responsibility of the caller.
f7f9143b 12621
b4a5b78b
JB
12622 TEMPFLAG, if nonzero, means that the underlying breakpoint
12623 should be temporary.
28010a5d 12624
b4a5b78b 12625 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 12626
349774ef 12627void
28010a5d 12628create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 12629 enum ada_exception_catchpoint_kind ex_kind,
28010a5d 12630 char *excep_string,
5845583d 12631 char *cond_string,
28010a5d 12632 int tempflag,
349774ef 12633 int disabled,
28010a5d
PA
12634 int from_tty)
12635{
12636 struct ada_catchpoint *c;
b4a5b78b
JB
12637 char *addr_string = NULL;
12638 const struct breakpoint_ops *ops = NULL;
12639 struct symtab_and_line sal
12640 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
28010a5d
PA
12641
12642 c = XNEW (struct ada_catchpoint);
12643 init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string,
349774ef 12644 ops, tempflag, disabled, from_tty);
28010a5d
PA
12645 c->excep_string = excep_string;
12646 create_excep_cond_exprs (c);
5845583d
JB
12647 if (cond_string != NULL)
12648 set_breakpoint_condition (&c->base, cond_string, from_tty);
3ea46bff 12649 install_breakpoint (0, &c->base, 1);
f7f9143b
JB
12650}
12651
9ac4176b
PA
12652/* Implement the "catch exception" command. */
12653
12654static void
12655catch_ada_exception_command (char *arg, int from_tty,
12656 struct cmd_list_element *command)
12657{
12658 struct gdbarch *gdbarch = get_current_arch ();
12659 int tempflag;
761269c8 12660 enum ada_exception_catchpoint_kind ex_kind;
28010a5d 12661 char *excep_string = NULL;
5845583d 12662 char *cond_string = NULL;
9ac4176b
PA
12663
12664 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12665
12666 if (!arg)
12667 arg = "";
b4a5b78b
JB
12668 catch_ada_exception_command_split (arg, &ex_kind, &excep_string,
12669 &cond_string);
12670 create_ada_exception_catchpoint (gdbarch, ex_kind,
12671 excep_string, cond_string,
349774ef
JB
12672 tempflag, 1 /* enabled */,
12673 from_tty);
9ac4176b
PA
12674}
12675
b4a5b78b 12676/* Split the arguments specified in a "catch assert" command.
5845583d 12677
b4a5b78b
JB
12678 ARGS contains the command's arguments (or the empty string if
12679 no arguments were passed).
5845583d
JB
12680
12681 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 12682 (the memory needs to be deallocated after use). */
5845583d 12683
b4a5b78b
JB
12684static void
12685catch_ada_assert_command_split (char *args, char **cond_string)
f7f9143b 12686{
5845583d 12687 args = skip_spaces (args);
f7f9143b 12688
5845583d
JB
12689 /* Check whether a condition was provided. */
12690 if (strncmp (args, "if", 2) == 0
12691 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 12692 {
5845583d 12693 args += 2;
0fcd72ba 12694 args = skip_spaces (args);
5845583d
JB
12695 if (args[0] == '\0')
12696 error (_("condition missing after `if' keyword"));
12697 *cond_string = xstrdup (args);
f7f9143b
JB
12698 }
12699
5845583d
JB
12700 /* Otherwise, there should be no other argument at the end of
12701 the command. */
12702 else if (args[0] != '\0')
12703 error (_("Junk at end of arguments."));
f7f9143b
JB
12704}
12705
9ac4176b
PA
12706/* Implement the "catch assert" command. */
12707
12708static void
12709catch_assert_command (char *arg, int from_tty,
12710 struct cmd_list_element *command)
12711{
12712 struct gdbarch *gdbarch = get_current_arch ();
12713 int tempflag;
5845583d 12714 char *cond_string = NULL;
9ac4176b
PA
12715
12716 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12717
12718 if (!arg)
12719 arg = "";
b4a5b78b 12720 catch_ada_assert_command_split (arg, &cond_string);
761269c8 12721 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
b4a5b78b 12722 NULL, cond_string,
349774ef
JB
12723 tempflag, 1 /* enabled */,
12724 from_tty);
9ac4176b 12725}
778865d3
JB
12726
12727/* Return non-zero if the symbol SYM is an Ada exception object. */
12728
12729static int
12730ada_is_exception_sym (struct symbol *sym)
12731{
12732 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
12733
12734 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
12735 && SYMBOL_CLASS (sym) != LOC_BLOCK
12736 && SYMBOL_CLASS (sym) != LOC_CONST
12737 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
12738 && type_name != NULL && strcmp (type_name, "exception") == 0);
12739}
12740
12741/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12742 Ada exception object. This matches all exceptions except the ones
12743 defined by the Ada language. */
12744
12745static int
12746ada_is_non_standard_exception_sym (struct symbol *sym)
12747{
12748 int i;
12749
12750 if (!ada_is_exception_sym (sym))
12751 return 0;
12752
12753 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12754 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
12755 return 0; /* A standard exception. */
12756
12757 /* Numeric_Error is also a standard exception, so exclude it.
12758 See the STANDARD_EXC description for more details as to why
12759 this exception is not listed in that array. */
12760 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
12761 return 0;
12762
12763 return 1;
12764}
12765
12766/* A helper function for qsort, comparing two struct ada_exc_info
12767 objects.
12768
12769 The comparison is determined first by exception name, and then
12770 by exception address. */
12771
12772static int
12773compare_ada_exception_info (const void *a, const void *b)
12774{
12775 const struct ada_exc_info *exc_a = (struct ada_exc_info *) a;
12776 const struct ada_exc_info *exc_b = (struct ada_exc_info *) b;
12777 int result;
12778
12779 result = strcmp (exc_a->name, exc_b->name);
12780 if (result != 0)
12781 return result;
12782
12783 if (exc_a->addr < exc_b->addr)
12784 return -1;
12785 if (exc_a->addr > exc_b->addr)
12786 return 1;
12787
12788 return 0;
12789}
12790
12791/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12792 routine, but keeping the first SKIP elements untouched.
12793
12794 All duplicates are also removed. */
12795
12796static void
12797sort_remove_dups_ada_exceptions_list (VEC(ada_exc_info) **exceptions,
12798 int skip)
12799{
12800 struct ada_exc_info *to_sort
12801 = VEC_address (ada_exc_info, *exceptions) + skip;
12802 int to_sort_len
12803 = VEC_length (ada_exc_info, *exceptions) - skip;
12804 int i, j;
12805
12806 qsort (to_sort, to_sort_len, sizeof (struct ada_exc_info),
12807 compare_ada_exception_info);
12808
12809 for (i = 1, j = 1; i < to_sort_len; i++)
12810 if (compare_ada_exception_info (&to_sort[i], &to_sort[j - 1]) != 0)
12811 to_sort[j++] = to_sort[i];
12812 to_sort_len = j;
12813 VEC_truncate(ada_exc_info, *exceptions, skip + to_sort_len);
12814}
12815
12816/* A function intended as the "name_matcher" callback in the struct
12817 quick_symbol_functions' expand_symtabs_matching method.
12818
12819 SEARCH_NAME is the symbol's search name.
12820
12821 If USER_DATA is not NULL, it is a pointer to a regext_t object
12822 used to match the symbol (by natural name). Otherwise, when USER_DATA
12823 is null, no filtering is performed, and all symbols are a positive
12824 match. */
12825
12826static int
12827ada_exc_search_name_matches (const char *search_name, void *user_data)
12828{
12829 regex_t *preg = user_data;
12830
12831 if (preg == NULL)
12832 return 1;
12833
12834 /* In Ada, the symbol "search name" is a linkage name, whereas
12835 the regular expression used to do the matching refers to
12836 the natural name. So match against the decoded name. */
12837 return (regexec (preg, ada_decode (search_name), 0, NULL, 0) == 0);
12838}
12839
12840/* Add all exceptions defined by the Ada standard whose name match
12841 a regular expression.
12842
12843 If PREG is not NULL, then this regexp_t object is used to
12844 perform the symbol name matching. Otherwise, no name-based
12845 filtering is performed.
12846
12847 EXCEPTIONS is a vector of exceptions to which matching exceptions
12848 gets pushed. */
12849
12850static void
12851ada_add_standard_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
12852{
12853 int i;
12854
12855 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12856 {
12857 if (preg == NULL
12858 || regexec (preg, standard_exc[i], 0, NULL, 0) == 0)
12859 {
12860 struct bound_minimal_symbol msymbol
12861 = ada_lookup_simple_minsym (standard_exc[i]);
12862
12863 if (msymbol.minsym != NULL)
12864 {
12865 struct ada_exc_info info
77e371c0 12866 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
778865d3
JB
12867
12868 VEC_safe_push (ada_exc_info, *exceptions, &info);
12869 }
12870 }
12871 }
12872}
12873
12874/* Add all Ada exceptions defined locally and accessible from the given
12875 FRAME.
12876
12877 If PREG is not NULL, then this regexp_t object is used to
12878 perform the symbol name matching. Otherwise, no name-based
12879 filtering is performed.
12880
12881 EXCEPTIONS is a vector of exceptions to which matching exceptions
12882 gets pushed. */
12883
12884static void
12885ada_add_exceptions_from_frame (regex_t *preg, struct frame_info *frame,
12886 VEC(ada_exc_info) **exceptions)
12887{
3977b71f 12888 const struct block *block = get_frame_block (frame, 0);
778865d3
JB
12889
12890 while (block != 0)
12891 {
12892 struct block_iterator iter;
12893 struct symbol *sym;
12894
12895 ALL_BLOCK_SYMBOLS (block, iter, sym)
12896 {
12897 switch (SYMBOL_CLASS (sym))
12898 {
12899 case LOC_TYPEDEF:
12900 case LOC_BLOCK:
12901 case LOC_CONST:
12902 break;
12903 default:
12904 if (ada_is_exception_sym (sym))
12905 {
12906 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
12907 SYMBOL_VALUE_ADDRESS (sym)};
12908
12909 VEC_safe_push (ada_exc_info, *exceptions, &info);
12910 }
12911 }
12912 }
12913 if (BLOCK_FUNCTION (block) != NULL)
12914 break;
12915 block = BLOCK_SUPERBLOCK (block);
12916 }
12917}
12918
12919/* Add all exceptions defined globally whose name name match
12920 a regular expression, excluding standard exceptions.
12921
12922 The reason we exclude standard exceptions is that they need
12923 to be handled separately: Standard exceptions are defined inside
12924 a runtime unit which is normally not compiled with debugging info,
12925 and thus usually do not show up in our symbol search. However,
12926 if the unit was in fact built with debugging info, we need to
12927 exclude them because they would duplicate the entry we found
12928 during the special loop that specifically searches for those
12929 standard exceptions.
12930
12931 If PREG is not NULL, then this regexp_t object is used to
12932 perform the symbol name matching. Otherwise, no name-based
12933 filtering is performed.
12934
12935 EXCEPTIONS is a vector of exceptions to which matching exceptions
12936 gets pushed. */
12937
12938static void
12939ada_add_global_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
12940{
12941 struct objfile *objfile;
43f3e411 12942 struct compunit_symtab *s;
778865d3 12943
bb4142cf
DE
12944 expand_symtabs_matching (NULL, ada_exc_search_name_matches,
12945 VARIABLES_DOMAIN, preg);
778865d3 12946
43f3e411 12947 ALL_COMPUNITS (objfile, s)
778865d3 12948 {
43f3e411 12949 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
778865d3
JB
12950 int i;
12951
12952 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
12953 {
12954 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
12955 struct block_iterator iter;
12956 struct symbol *sym;
12957
12958 ALL_BLOCK_SYMBOLS (b, iter, sym)
12959 if (ada_is_non_standard_exception_sym (sym)
12960 && (preg == NULL
12961 || regexec (preg, SYMBOL_NATURAL_NAME (sym),
12962 0, NULL, 0) == 0))
12963 {
12964 struct ada_exc_info info
12965 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
12966
12967 VEC_safe_push (ada_exc_info, *exceptions, &info);
12968 }
12969 }
12970 }
12971}
12972
12973/* Implements ada_exceptions_list with the regular expression passed
12974 as a regex_t, rather than a string.
12975
12976 If not NULL, PREG is used to filter out exceptions whose names
12977 do not match. Otherwise, all exceptions are listed. */
12978
12979static VEC(ada_exc_info) *
12980ada_exceptions_list_1 (regex_t *preg)
12981{
12982 VEC(ada_exc_info) *result = NULL;
12983 struct cleanup *old_chain
12984 = make_cleanup (VEC_cleanup (ada_exc_info), &result);
12985 int prev_len;
12986
12987 /* First, list the known standard exceptions. These exceptions
12988 need to be handled separately, as they are usually defined in
12989 runtime units that have been compiled without debugging info. */
12990
12991 ada_add_standard_exceptions (preg, &result);
12992
12993 /* Next, find all exceptions whose scope is local and accessible
12994 from the currently selected frame. */
12995
12996 if (has_stack_frames ())
12997 {
12998 prev_len = VEC_length (ada_exc_info, result);
12999 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13000 &result);
13001 if (VEC_length (ada_exc_info, result) > prev_len)
13002 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13003 }
13004
13005 /* Add all exceptions whose scope is global. */
13006
13007 prev_len = VEC_length (ada_exc_info, result);
13008 ada_add_global_exceptions (preg, &result);
13009 if (VEC_length (ada_exc_info, result) > prev_len)
13010 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13011
13012 discard_cleanups (old_chain);
13013 return result;
13014}
13015
13016/* Return a vector of ada_exc_info.
13017
13018 If REGEXP is NULL, all exceptions are included in the result.
13019 Otherwise, it should contain a valid regular expression,
13020 and only the exceptions whose names match that regular expression
13021 are included in the result.
13022
13023 The exceptions are sorted in the following order:
13024 - Standard exceptions (defined by the Ada language), in
13025 alphabetical order;
13026 - Exceptions only visible from the current frame, in
13027 alphabetical order;
13028 - Exceptions whose scope is global, in alphabetical order. */
13029
13030VEC(ada_exc_info) *
13031ada_exceptions_list (const char *regexp)
13032{
13033 VEC(ada_exc_info) *result = NULL;
13034 struct cleanup *old_chain = NULL;
13035 regex_t reg;
13036
13037 if (regexp != NULL)
13038 old_chain = compile_rx_or_error (&reg, regexp,
13039 _("invalid regular expression"));
13040
13041 result = ada_exceptions_list_1 (regexp != NULL ? &reg : NULL);
13042
13043 if (old_chain != NULL)
13044 do_cleanups (old_chain);
13045 return result;
13046}
13047
13048/* Implement the "info exceptions" command. */
13049
13050static void
13051info_exceptions_command (char *regexp, int from_tty)
13052{
13053 VEC(ada_exc_info) *exceptions;
13054 struct cleanup *cleanup;
13055 struct gdbarch *gdbarch = get_current_arch ();
13056 int ix;
13057 struct ada_exc_info *info;
13058
13059 exceptions = ada_exceptions_list (regexp);
13060 cleanup = make_cleanup (VEC_cleanup (ada_exc_info), &exceptions);
13061
13062 if (regexp != NULL)
13063 printf_filtered
13064 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13065 else
13066 printf_filtered (_("All defined Ada exceptions:\n"));
13067
13068 for (ix = 0; VEC_iterate(ada_exc_info, exceptions, ix, info); ix++)
13069 printf_filtered ("%s: %s\n", info->name, paddress (gdbarch, info->addr));
13070
13071 do_cleanups (cleanup);
13072}
13073
4c4b4cd2
PH
13074 /* Operators */
13075/* Information about operators given special treatment in functions
13076 below. */
13077/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13078
13079#define ADA_OPERATORS \
13080 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13081 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13082 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13083 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13084 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13085 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13086 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13087 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13088 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13089 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13090 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13091 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13092 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13093 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13094 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
13095 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13096 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13097 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13098 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
13099
13100static void
554794dc
SDJ
13101ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13102 int *argsp)
4c4b4cd2
PH
13103{
13104 switch (exp->elts[pc - 1].opcode)
13105 {
76a01679 13106 default:
4c4b4cd2
PH
13107 operator_length_standard (exp, pc, oplenp, argsp);
13108 break;
13109
13110#define OP_DEFN(op, len, args, binop) \
13111 case op: *oplenp = len; *argsp = args; break;
13112 ADA_OPERATORS;
13113#undef OP_DEFN
52ce6436
PH
13114
13115 case OP_AGGREGATE:
13116 *oplenp = 3;
13117 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13118 break;
13119
13120 case OP_CHOICES:
13121 *oplenp = 3;
13122 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13123 break;
4c4b4cd2
PH
13124 }
13125}
13126
c0201579
JK
13127/* Implementation of the exp_descriptor method operator_check. */
13128
13129static int
13130ada_operator_check (struct expression *exp, int pos,
13131 int (*objfile_func) (struct objfile *objfile, void *data),
13132 void *data)
13133{
13134 const union exp_element *const elts = exp->elts;
13135 struct type *type = NULL;
13136
13137 switch (elts[pos].opcode)
13138 {
13139 case UNOP_IN_RANGE:
13140 case UNOP_QUAL:
13141 type = elts[pos + 1].type;
13142 break;
13143
13144 default:
13145 return operator_check_standard (exp, pos, objfile_func, data);
13146 }
13147
13148 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13149
13150 if (type && TYPE_OBJFILE (type)
13151 && (*objfile_func) (TYPE_OBJFILE (type), data))
13152 return 1;
13153
13154 return 0;
13155}
13156
4c4b4cd2
PH
13157static char *
13158ada_op_name (enum exp_opcode opcode)
13159{
13160 switch (opcode)
13161 {
76a01679 13162 default:
4c4b4cd2 13163 return op_name_standard (opcode);
52ce6436 13164
4c4b4cd2
PH
13165#define OP_DEFN(op, len, args, binop) case op: return #op;
13166 ADA_OPERATORS;
13167#undef OP_DEFN
52ce6436
PH
13168
13169 case OP_AGGREGATE:
13170 return "OP_AGGREGATE";
13171 case OP_CHOICES:
13172 return "OP_CHOICES";
13173 case OP_NAME:
13174 return "OP_NAME";
4c4b4cd2
PH
13175 }
13176}
13177
13178/* As for operator_length, but assumes PC is pointing at the first
13179 element of the operator, and gives meaningful results only for the
52ce6436 13180 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
13181
13182static void
76a01679
JB
13183ada_forward_operator_length (struct expression *exp, int pc,
13184 int *oplenp, int *argsp)
4c4b4cd2 13185{
76a01679 13186 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
13187 {
13188 default:
13189 *oplenp = *argsp = 0;
13190 break;
52ce6436 13191
4c4b4cd2
PH
13192#define OP_DEFN(op, len, args, binop) \
13193 case op: *oplenp = len; *argsp = args; break;
13194 ADA_OPERATORS;
13195#undef OP_DEFN
52ce6436
PH
13196
13197 case OP_AGGREGATE:
13198 *oplenp = 3;
13199 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13200 break;
13201
13202 case OP_CHOICES:
13203 *oplenp = 3;
13204 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13205 break;
13206
13207 case OP_STRING:
13208 case OP_NAME:
13209 {
13210 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13211
52ce6436
PH
13212 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13213 *argsp = 0;
13214 break;
13215 }
4c4b4cd2
PH
13216 }
13217}
13218
13219static int
13220ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13221{
13222 enum exp_opcode op = exp->elts[elt].opcode;
13223 int oplen, nargs;
13224 int pc = elt;
13225 int i;
76a01679 13226
4c4b4cd2
PH
13227 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13228
76a01679 13229 switch (op)
4c4b4cd2 13230 {
76a01679 13231 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13232 case OP_ATR_FIRST:
13233 case OP_ATR_LAST:
13234 case OP_ATR_LENGTH:
13235 case OP_ATR_IMAGE:
13236 case OP_ATR_MAX:
13237 case OP_ATR_MIN:
13238 case OP_ATR_MODULUS:
13239 case OP_ATR_POS:
13240 case OP_ATR_SIZE:
13241 case OP_ATR_TAG:
13242 case OP_ATR_VAL:
13243 break;
13244
13245 case UNOP_IN_RANGE:
13246 case UNOP_QUAL:
323e0a4a
AC
13247 /* XXX: gdb_sprint_host_address, type_sprint */
13248 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13249 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13250 fprintf_filtered (stream, " (");
13251 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13252 fprintf_filtered (stream, ")");
13253 break;
13254 case BINOP_IN_BOUNDS:
52ce6436
PH
13255 fprintf_filtered (stream, " (%d)",
13256 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13257 break;
13258 case TERNOP_IN_RANGE:
13259 break;
13260
52ce6436
PH
13261 case OP_AGGREGATE:
13262 case OP_OTHERS:
13263 case OP_DISCRETE_RANGE:
13264 case OP_POSITIONAL:
13265 case OP_CHOICES:
13266 break;
13267
13268 case OP_NAME:
13269 case OP_STRING:
13270 {
13271 char *name = &exp->elts[elt + 2].string;
13272 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 13273
52ce6436
PH
13274 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13275 break;
13276 }
13277
4c4b4cd2
PH
13278 default:
13279 return dump_subexp_body_standard (exp, stream, elt);
13280 }
13281
13282 elt += oplen;
13283 for (i = 0; i < nargs; i += 1)
13284 elt = dump_subexp (exp, stream, elt);
13285
13286 return elt;
13287}
13288
13289/* The Ada extension of print_subexp (q.v.). */
13290
76a01679
JB
13291static void
13292ada_print_subexp (struct expression *exp, int *pos,
13293 struct ui_file *stream, enum precedence prec)
4c4b4cd2 13294{
52ce6436 13295 int oplen, nargs, i;
4c4b4cd2
PH
13296 int pc = *pos;
13297 enum exp_opcode op = exp->elts[pc].opcode;
13298
13299 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13300
52ce6436 13301 *pos += oplen;
4c4b4cd2
PH
13302 switch (op)
13303 {
13304 default:
52ce6436 13305 *pos -= oplen;
4c4b4cd2
PH
13306 print_subexp_standard (exp, pos, stream, prec);
13307 return;
13308
13309 case OP_VAR_VALUE:
4c4b4cd2
PH
13310 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13311 return;
13312
13313 case BINOP_IN_BOUNDS:
323e0a4a 13314 /* XXX: sprint_subexp */
4c4b4cd2 13315 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13316 fputs_filtered (" in ", stream);
4c4b4cd2 13317 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13318 fputs_filtered ("'range", stream);
4c4b4cd2 13319 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
13320 fprintf_filtered (stream, "(%ld)",
13321 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
13322 return;
13323
13324 case TERNOP_IN_RANGE:
4c4b4cd2 13325 if (prec >= PREC_EQUAL)
76a01679 13326 fputs_filtered ("(", stream);
323e0a4a 13327 /* XXX: sprint_subexp */
4c4b4cd2 13328 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13329 fputs_filtered (" in ", stream);
4c4b4cd2
PH
13330 print_subexp (exp, pos, stream, PREC_EQUAL);
13331 fputs_filtered (" .. ", stream);
13332 print_subexp (exp, pos, stream, PREC_EQUAL);
13333 if (prec >= PREC_EQUAL)
76a01679
JB
13334 fputs_filtered (")", stream);
13335 return;
4c4b4cd2
PH
13336
13337 case OP_ATR_FIRST:
13338 case OP_ATR_LAST:
13339 case OP_ATR_LENGTH:
13340 case OP_ATR_IMAGE:
13341 case OP_ATR_MAX:
13342 case OP_ATR_MIN:
13343 case OP_ATR_MODULUS:
13344 case OP_ATR_POS:
13345 case OP_ATR_SIZE:
13346 case OP_ATR_TAG:
13347 case OP_ATR_VAL:
4c4b4cd2 13348 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
13349 {
13350 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
13351 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13352 &type_print_raw_options);
76a01679
JB
13353 *pos += 3;
13354 }
4c4b4cd2 13355 else
76a01679 13356 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
13357 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13358 if (nargs > 1)
76a01679
JB
13359 {
13360 int tem;
5b4ee69b 13361
76a01679
JB
13362 for (tem = 1; tem < nargs; tem += 1)
13363 {
13364 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13365 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13366 }
13367 fputs_filtered (")", stream);
13368 }
4c4b4cd2 13369 return;
14f9c5c9 13370
4c4b4cd2 13371 case UNOP_QUAL:
4c4b4cd2
PH
13372 type_print (exp->elts[pc + 1].type, "", stream, 0);
13373 fputs_filtered ("'(", stream);
13374 print_subexp (exp, pos, stream, PREC_PREFIX);
13375 fputs_filtered (")", stream);
13376 return;
14f9c5c9 13377
4c4b4cd2 13378 case UNOP_IN_RANGE:
323e0a4a 13379 /* XXX: sprint_subexp */
4c4b4cd2 13380 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13381 fputs_filtered (" in ", stream);
79d43c61
TT
13382 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13383 &type_print_raw_options);
4c4b4cd2 13384 return;
52ce6436
PH
13385
13386 case OP_DISCRETE_RANGE:
13387 print_subexp (exp, pos, stream, PREC_SUFFIX);
13388 fputs_filtered ("..", stream);
13389 print_subexp (exp, pos, stream, PREC_SUFFIX);
13390 return;
13391
13392 case OP_OTHERS:
13393 fputs_filtered ("others => ", stream);
13394 print_subexp (exp, pos, stream, PREC_SUFFIX);
13395 return;
13396
13397 case OP_CHOICES:
13398 for (i = 0; i < nargs-1; i += 1)
13399 {
13400 if (i > 0)
13401 fputs_filtered ("|", stream);
13402 print_subexp (exp, pos, stream, PREC_SUFFIX);
13403 }
13404 fputs_filtered (" => ", stream);
13405 print_subexp (exp, pos, stream, PREC_SUFFIX);
13406 return;
13407
13408 case OP_POSITIONAL:
13409 print_subexp (exp, pos, stream, PREC_SUFFIX);
13410 return;
13411
13412 case OP_AGGREGATE:
13413 fputs_filtered ("(", stream);
13414 for (i = 0; i < nargs; i += 1)
13415 {
13416 if (i > 0)
13417 fputs_filtered (", ", stream);
13418 print_subexp (exp, pos, stream, PREC_SUFFIX);
13419 }
13420 fputs_filtered (")", stream);
13421 return;
4c4b4cd2
PH
13422 }
13423}
14f9c5c9
AS
13424
13425/* Table mapping opcodes into strings for printing operators
13426 and precedences of the operators. */
13427
d2e4a39e
AS
13428static const struct op_print ada_op_print_tab[] = {
13429 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13430 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13431 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13432 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13433 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13434 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13435 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13436 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13437 {"<=", BINOP_LEQ, PREC_ORDER, 0},
13438 {">=", BINOP_GEQ, PREC_ORDER, 0},
13439 {">", BINOP_GTR, PREC_ORDER, 0},
13440 {"<", BINOP_LESS, PREC_ORDER, 0},
13441 {">>", BINOP_RSH, PREC_SHIFT, 0},
13442 {"<<", BINOP_LSH, PREC_SHIFT, 0},
13443 {"+", BINOP_ADD, PREC_ADD, 0},
13444 {"-", BINOP_SUB, PREC_ADD, 0},
13445 {"&", BINOP_CONCAT, PREC_ADD, 0},
13446 {"*", BINOP_MUL, PREC_MUL, 0},
13447 {"/", BINOP_DIV, PREC_MUL, 0},
13448 {"rem", BINOP_REM, PREC_MUL, 0},
13449 {"mod", BINOP_MOD, PREC_MUL, 0},
13450 {"**", BINOP_EXP, PREC_REPEAT, 0},
13451 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13452 {"-", UNOP_NEG, PREC_PREFIX, 0},
13453 {"+", UNOP_PLUS, PREC_PREFIX, 0},
13454 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13455 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13456 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
13457 {".all", UNOP_IND, PREC_SUFFIX, 1},
13458 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13459 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
d2e4a39e 13460 {NULL, 0, 0, 0}
14f9c5c9
AS
13461};
13462\f
72d5681a
PH
13463enum ada_primitive_types {
13464 ada_primitive_type_int,
13465 ada_primitive_type_long,
13466 ada_primitive_type_short,
13467 ada_primitive_type_char,
13468 ada_primitive_type_float,
13469 ada_primitive_type_double,
13470 ada_primitive_type_void,
13471 ada_primitive_type_long_long,
13472 ada_primitive_type_long_double,
13473 ada_primitive_type_natural,
13474 ada_primitive_type_positive,
13475 ada_primitive_type_system_address,
13476 nr_ada_primitive_types
13477};
6c038f32
PH
13478
13479static void
d4a9a881 13480ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
13481 struct language_arch_info *lai)
13482{
d4a9a881 13483 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 13484
72d5681a 13485 lai->primitive_type_vector
d4a9a881 13486 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 13487 struct type *);
e9bb382b
UW
13488
13489 lai->primitive_type_vector [ada_primitive_type_int]
13490 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13491 0, "integer");
13492 lai->primitive_type_vector [ada_primitive_type_long]
13493 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13494 0, "long_integer");
13495 lai->primitive_type_vector [ada_primitive_type_short]
13496 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13497 0, "short_integer");
13498 lai->string_char_type
13499 = lai->primitive_type_vector [ada_primitive_type_char]
13500 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
13501 lai->primitive_type_vector [ada_primitive_type_float]
13502 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13503 "float", NULL);
13504 lai->primitive_type_vector [ada_primitive_type_double]
13505 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13506 "long_float", NULL);
13507 lai->primitive_type_vector [ada_primitive_type_long_long]
13508 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13509 0, "long_long_integer");
13510 lai->primitive_type_vector [ada_primitive_type_long_double]
13511 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13512 "long_long_float", NULL);
13513 lai->primitive_type_vector [ada_primitive_type_natural]
13514 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13515 0, "natural");
13516 lai->primitive_type_vector [ada_primitive_type_positive]
13517 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13518 0, "positive");
13519 lai->primitive_type_vector [ada_primitive_type_void]
13520 = builtin->builtin_void;
13521
13522 lai->primitive_type_vector [ada_primitive_type_system_address]
13523 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
72d5681a
PH
13524 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
13525 = "system__address";
fbb06eb1 13526
47e729a8 13527 lai->bool_type_symbol = NULL;
fbb06eb1 13528 lai->bool_type_default = builtin->builtin_bool;
6c038f32 13529}
6c038f32
PH
13530\f
13531 /* Language vector */
13532
13533/* Not really used, but needed in the ada_language_defn. */
13534
13535static void
6c7a06a3 13536emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 13537{
6c7a06a3 13538 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
13539}
13540
13541static int
410a0ff2 13542parse (struct parser_state *ps)
6c038f32
PH
13543{
13544 warnings_issued = 0;
410a0ff2 13545 return ada_parse (ps);
6c038f32
PH
13546}
13547
13548static const struct exp_descriptor ada_exp_descriptor = {
13549 ada_print_subexp,
13550 ada_operator_length,
c0201579 13551 ada_operator_check,
6c038f32
PH
13552 ada_op_name,
13553 ada_dump_subexp_body,
13554 ada_evaluate_subexp
13555};
13556
1a119f36 13557/* Implement the "la_get_symbol_name_cmp" language_defn method
74ccd7f5
JB
13558 for Ada. */
13559
1a119f36
JB
13560static symbol_name_cmp_ftype
13561ada_get_symbol_name_cmp (const char *lookup_name)
74ccd7f5
JB
13562{
13563 if (should_use_wild_match (lookup_name))
13564 return wild_match;
13565 else
13566 return compare_names;
13567}
13568
a5ee536b
JB
13569/* Implement the "la_read_var_value" language_defn method for Ada. */
13570
13571static struct value *
13572ada_read_var_value (struct symbol *var, struct frame_info *frame)
13573{
3977b71f 13574 const struct block *frame_block = NULL;
a5ee536b
JB
13575 struct symbol *renaming_sym = NULL;
13576
13577 /* The only case where default_read_var_value is not sufficient
13578 is when VAR is a renaming... */
13579 if (frame)
13580 frame_block = get_frame_block (frame, NULL);
13581 if (frame_block)
13582 renaming_sym = ada_find_renaming_symbol (var, frame_block);
13583 if (renaming_sym != NULL)
13584 return ada_read_renaming_var_value (renaming_sym, frame_block);
13585
13586 /* This is a typical case where we expect the default_read_var_value
13587 function to work. */
13588 return default_read_var_value (var, frame);
13589}
13590
6c038f32
PH
13591const struct language_defn ada_language_defn = {
13592 "ada", /* Language name */
6abde28f 13593 "Ada",
6c038f32 13594 language_ada,
6c038f32 13595 range_check_off,
6c038f32
PH
13596 case_sensitive_on, /* Yes, Ada is case-insensitive, but
13597 that's not quite what this means. */
6c038f32 13598 array_row_major,
9a044a89 13599 macro_expansion_no,
6c038f32
PH
13600 &ada_exp_descriptor,
13601 parse,
13602 ada_error,
13603 resolve,
13604 ada_printchar, /* Print a character constant */
13605 ada_printstr, /* Function to print string constant */
13606 emit_char, /* Function to print single char (not used) */
6c038f32 13607 ada_print_type, /* Print a type using appropriate syntax */
be942545 13608 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
13609 ada_val_print, /* Print a value using appropriate syntax */
13610 ada_value_print, /* Print a top-level value */
a5ee536b 13611 ada_read_var_value, /* la_read_var_value */
6c038f32 13612 NULL, /* Language specific skip_trampoline */
2b2d9e11 13613 NULL, /* name_of_this */
6c038f32
PH
13614 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
13615 basic_lookup_transparent_type, /* lookup_transparent_type */
13616 ada_la_decode, /* Language specific symbol demangler */
0963b4bd
MS
13617 NULL, /* Language specific
13618 class_name_from_physname */
6c038f32
PH
13619 ada_op_print_tab, /* expression operators for printing */
13620 0, /* c-style arrays */
13621 1, /* String lower bound */
6c038f32 13622 ada_get_gdb_completer_word_break_characters,
41d27058 13623 ada_make_symbol_completion_list,
72d5681a 13624 ada_language_arch_info,
e79af960 13625 ada_print_array_index,
41f1b697 13626 default_pass_by_reference,
ae6a3a4c 13627 c_get_string,
1a119f36 13628 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
f8eba3c6 13629 ada_iterate_over_symbols,
a53b64ea 13630 &ada_varobj_ops,
bb2ec1b3
TT
13631 NULL,
13632 NULL,
6c038f32
PH
13633 LANG_MAGIC
13634};
13635
2c0b251b
PA
13636/* Provide a prototype to silence -Wmissing-prototypes. */
13637extern initialize_file_ftype _initialize_ada_language;
13638
5bf03f13
JB
13639/* Command-list for the "set/show ada" prefix command. */
13640static struct cmd_list_element *set_ada_list;
13641static struct cmd_list_element *show_ada_list;
13642
13643/* Implement the "set ada" prefix command. */
13644
13645static void
13646set_ada_command (char *arg, int from_tty)
13647{
13648 printf_unfiltered (_(\
13649"\"set ada\" must be followed by the name of a setting.\n"));
635c7e8a 13650 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
5bf03f13
JB
13651}
13652
13653/* Implement the "show ada" prefix command. */
13654
13655static void
13656show_ada_command (char *args, int from_tty)
13657{
13658 cmd_show_list (show_ada_list, from_tty, "");
13659}
13660
2060206e
PA
13661static void
13662initialize_ada_catchpoint_ops (void)
13663{
13664 struct breakpoint_ops *ops;
13665
13666 initialize_breakpoint_ops ();
13667
13668 ops = &catch_exception_breakpoint_ops;
13669 *ops = bkpt_breakpoint_ops;
13670 ops->dtor = dtor_catch_exception;
13671 ops->allocate_location = allocate_location_catch_exception;
13672 ops->re_set = re_set_catch_exception;
13673 ops->check_status = check_status_catch_exception;
13674 ops->print_it = print_it_catch_exception;
13675 ops->print_one = print_one_catch_exception;
13676 ops->print_mention = print_mention_catch_exception;
13677 ops->print_recreate = print_recreate_catch_exception;
13678
13679 ops = &catch_exception_unhandled_breakpoint_ops;
13680 *ops = bkpt_breakpoint_ops;
13681 ops->dtor = dtor_catch_exception_unhandled;
13682 ops->allocate_location = allocate_location_catch_exception_unhandled;
13683 ops->re_set = re_set_catch_exception_unhandled;
13684 ops->check_status = check_status_catch_exception_unhandled;
13685 ops->print_it = print_it_catch_exception_unhandled;
13686 ops->print_one = print_one_catch_exception_unhandled;
13687 ops->print_mention = print_mention_catch_exception_unhandled;
13688 ops->print_recreate = print_recreate_catch_exception_unhandled;
13689
13690 ops = &catch_assert_breakpoint_ops;
13691 *ops = bkpt_breakpoint_ops;
13692 ops->dtor = dtor_catch_assert;
13693 ops->allocate_location = allocate_location_catch_assert;
13694 ops->re_set = re_set_catch_assert;
13695 ops->check_status = check_status_catch_assert;
13696 ops->print_it = print_it_catch_assert;
13697 ops->print_one = print_one_catch_assert;
13698 ops->print_mention = print_mention_catch_assert;
13699 ops->print_recreate = print_recreate_catch_assert;
13700}
13701
3d9434b5
JB
13702/* This module's 'new_objfile' observer. */
13703
13704static void
13705ada_new_objfile_observer (struct objfile *objfile)
13706{
13707 ada_clear_symbol_cache ();
13708}
13709
13710/* This module's 'free_objfile' observer. */
13711
13712static void
13713ada_free_objfile_observer (struct objfile *objfile)
13714{
13715 ada_clear_symbol_cache ();
13716}
13717
d2e4a39e 13718void
6c038f32 13719_initialize_ada_language (void)
14f9c5c9 13720{
6c038f32
PH
13721 add_language (&ada_language_defn);
13722
2060206e
PA
13723 initialize_ada_catchpoint_ops ();
13724
5bf03f13
JB
13725 add_prefix_cmd ("ada", no_class, set_ada_command,
13726 _("Prefix command for changing Ada-specfic settings"),
13727 &set_ada_list, "set ada ", 0, &setlist);
13728
13729 add_prefix_cmd ("ada", no_class, show_ada_command,
13730 _("Generic command for showing Ada-specific settings."),
13731 &show_ada_list, "show ada ", 0, &showlist);
13732
13733 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13734 &trust_pad_over_xvs, _("\
13735Enable or disable an optimization trusting PAD types over XVS types"), _("\
13736Show whether an optimization trusting PAD types over XVS types is activated"),
13737 _("\
13738This is related to the encoding used by the GNAT compiler. The debugger\n\
13739should normally trust the contents of PAD types, but certain older versions\n\
13740of GNAT have a bug that sometimes causes the information in the PAD type\n\
13741to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13742work around this bug. It is always safe to turn this option \"off\", but\n\
13743this incurs a slight performance penalty, so it is recommended to NOT change\n\
13744this option to \"off\" unless necessary."),
13745 NULL, NULL, &set_ada_list, &show_ada_list);
13746
9ac4176b
PA
13747 add_catch_command ("exception", _("\
13748Catch Ada exceptions, when raised.\n\
13749With an argument, catch only exceptions with the given name."),
13750 catch_ada_exception_command,
13751 NULL,
13752 CATCH_PERMANENT,
13753 CATCH_TEMPORARY);
13754 add_catch_command ("assert", _("\
13755Catch failed Ada assertions, when raised.\n\
13756With an argument, catch only exceptions with the given name."),
13757 catch_assert_command,
13758 NULL,
13759 CATCH_PERMANENT,
13760 CATCH_TEMPORARY);
13761
6c038f32 13762 varsize_limit = 65536;
6c038f32 13763
778865d3
JB
13764 add_info ("exceptions", info_exceptions_command,
13765 _("\
13766List all Ada exception names.\n\
13767If a regular expression is passed as an argument, only those matching\n\
13768the regular expression are listed."));
13769
c6044dd1
JB
13770 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
13771 _("Set Ada maintenance-related variables."),
13772 &maint_set_ada_cmdlist, "maintenance set ada ",
13773 0/*allow-unknown*/, &maintenance_set_cmdlist);
13774
13775 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
13776 _("Show Ada maintenance-related variables"),
13777 &maint_show_ada_cmdlist, "maintenance show ada ",
13778 0/*allow-unknown*/, &maintenance_show_cmdlist);
13779
13780 add_setshow_boolean_cmd
13781 ("ignore-descriptive-types", class_maintenance,
13782 &ada_ignore_descriptive_types_p,
13783 _("Set whether descriptive types generated by GNAT should be ignored."),
13784 _("Show whether descriptive types generated by GNAT should be ignored."),
13785 _("\
13786When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13787DWARF attribute."),
13788 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
13789
6c038f32
PH
13790 obstack_init (&symbol_list_obstack);
13791
13792 decoded_names_store = htab_create_alloc
13793 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
13794 NULL, xcalloc, xfree);
6b69afc4 13795
3d9434b5
JB
13796 /* The ada-lang observers. */
13797 observer_attach_new_objfile (ada_new_objfile_observer);
13798 observer_attach_free_objfile (ada_free_objfile_observer);
e802dbe0 13799 observer_attach_inferior_exit (ada_inferior_exit);
ee01b665
JB
13800
13801 /* Setup various context-specific data. */
e802dbe0 13802 ada_inferior_data
8e260fc0 13803 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
ee01b665
JB
13804 ada_pspace_data_handle
13805 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14f9c5c9 13806}