]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
PR c++/15401:
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
6e681866 1/* Ada language support routines for GDB, the GNU debugger.
10a2c479 2
28e7fd62 3 Copyright (C) 1992-2013 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 <stdio.h>
0c30c098 23#include "gdb_string.h"
14f9c5c9
AS
24#include <ctype.h>
25#include <stdarg.h>
26#include "demangle.h"
4c4b4cd2
PH
27#include "gdb_regex.h"
28#include "frame.h"
14f9c5c9
AS
29#include "symtab.h"
30#include "gdbtypes.h"
31#include "gdbcmd.h"
32#include "expression.h"
33#include "parser-defs.h"
34#include "language.h"
35#include "c-lang.h"
36#include "inferior.h"
37#include "symfile.h"
38#include "objfiles.h"
39#include "breakpoint.h"
40#include "gdbcore.h"
4c4b4cd2
PH
41#include "hashtab.h"
42#include "gdb_obstack.h"
14f9c5c9 43#include "ada-lang.h"
4c4b4cd2
PH
44#include "completer.h"
45#include "gdb_stat.h"
46#ifdef UI_OUT
14f9c5c9 47#include "ui-out.h"
4c4b4cd2 48#endif
fe898f56 49#include "block.h"
04714b91 50#include "infcall.h"
de4f826b 51#include "dictionary.h"
60250e8b 52#include "exceptions.h"
f7f9143b
JB
53#include "annotate.h"
54#include "valprint.h"
9bbc9174 55#include "source.h"
0259addd 56#include "observer.h"
2ba95b9b 57#include "vec.h"
692465f1 58#include "stack.h"
fa864999 59#include "gdb_vecs.h"
79d43c61 60#include "typeprint.h"
14f9c5c9 61
ccefe4c4 62#include "psymtab.h"
40bc484c 63#include "value.h"
956a9fb9 64#include "mi/mi-common.h"
9ac4176b 65#include "arch-utils.h"
28010a5d 66#include "exceptions.h"
0fcd72ba 67#include "cli/cli-utils.h"
ccefe4c4 68
4c4b4cd2 69/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 70 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
71 Copied from valarith.c. */
72
73#ifndef TRUNCATION_TOWARDS_ZERO
74#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
75#endif
76
d2e4a39e 77static struct type *desc_base_type (struct type *);
14f9c5c9 78
d2e4a39e 79static struct type *desc_bounds_type (struct type *);
14f9c5c9 80
d2e4a39e 81static struct value *desc_bounds (struct value *);
14f9c5c9 82
d2e4a39e 83static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 84
d2e4a39e 85static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 86
556bdfd4 87static struct type *desc_data_target_type (struct type *);
14f9c5c9 88
d2e4a39e 89static struct value *desc_data (struct value *);
14f9c5c9 90
d2e4a39e 91static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 92
d2e4a39e 93static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 94
d2e4a39e 95static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 96
d2e4a39e 97static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 98
d2e4a39e 99static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 100
d2e4a39e 101static struct type *desc_index_type (struct type *, int);
14f9c5c9 102
d2e4a39e 103static int desc_arity (struct type *);
14f9c5c9 104
d2e4a39e 105static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 106
d2e4a39e 107static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 108
40658b94
PH
109static int full_match (const char *, const char *);
110
40bc484c 111static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 112
4c4b4cd2 113static void ada_add_block_symbols (struct obstack *,
76a01679 114 struct block *, const char *,
2570f2b7 115 domain_enum, struct objfile *, int);
14f9c5c9 116
4c4b4cd2 117static int is_nonfunction (struct ada_symbol_info *, int);
14f9c5c9 118
76a01679 119static void add_defn_to_vec (struct obstack *, struct symbol *,
2570f2b7 120 struct block *);
14f9c5c9 121
4c4b4cd2
PH
122static int num_defns_collected (struct obstack *);
123
124static struct ada_symbol_info *defns_collected (struct obstack *, int);
14f9c5c9 125
4c4b4cd2 126static struct value *resolve_subexp (struct expression **, int *, int,
76a01679 127 struct type *);
14f9c5c9 128
d2e4a39e 129static void replace_operator_with_call (struct expression **, int, int, int,
270140bd 130 struct symbol *, const struct block *);
14f9c5c9 131
d2e4a39e 132static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 133
4c4b4cd2
PH
134static char *ada_op_name (enum exp_opcode);
135
136static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 137
d2e4a39e 138static int numeric_type_p (struct type *);
14f9c5c9 139
d2e4a39e 140static int integer_type_p (struct type *);
14f9c5c9 141
d2e4a39e 142static int scalar_type_p (struct type *);
14f9c5c9 143
d2e4a39e 144static int discrete_type_p (struct type *);
14f9c5c9 145
aeb5907d
JB
146static enum ada_renaming_category parse_old_style_renaming (struct type *,
147 const char **,
148 int *,
149 const char **);
150
151static struct symbol *find_old_style_renaming_symbol (const char *,
270140bd 152 const struct block *);
aeb5907d 153
4c4b4cd2 154static struct type *ada_lookup_struct_elt_type (struct type *, char *,
76a01679 155 int, int, int *);
4c4b4cd2 156
d2e4a39e 157static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 158
b4ba55a1
JB
159static struct type *ada_find_parallel_type_with_name (struct type *,
160 const char *);
161
d2e4a39e 162static int is_dynamic_field (struct type *, int);
14f9c5c9 163
10a2c479 164static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 165 const gdb_byte *,
4c4b4cd2
PH
166 CORE_ADDR, struct value *);
167
168static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 169
28c85d6c 170static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 171
d2e4a39e 172static struct type *to_static_fixed_type (struct type *);
f192137b 173static struct type *static_unwrap_type (struct type *type);
14f9c5c9 174
d2e4a39e 175static struct value *unwrap_value (struct value *);
14f9c5c9 176
ad82864c 177static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 178
ad82864c 179static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 180
ad82864c
JB
181static long decode_packed_array_bitsize (struct type *);
182
183static struct value *decode_constrained_packed_array (struct value *);
184
185static int ada_is_packed_array_type (struct type *);
186
187static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 188
d2e4a39e 189static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 190 struct value **);
14f9c5c9 191
50810684 192static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
52ce6436 193
4c4b4cd2
PH
194static struct value *coerce_unspec_val_to_type (struct value *,
195 struct type *);
14f9c5c9 196
d2e4a39e 197static struct value *get_var_value (char *, char *);
14f9c5c9 198
d2e4a39e 199static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 200
d2e4a39e 201static int equiv_types (struct type *, struct type *);
14f9c5c9 202
d2e4a39e 203static int is_name_suffix (const char *);
14f9c5c9 204
73589123
PH
205static int advance_wild_match (const char **, const char *, int);
206
207static int wild_match (const char *, const char *);
14f9c5c9 208
d2e4a39e 209static struct value *ada_coerce_ref (struct value *);
14f9c5c9 210
4c4b4cd2
PH
211static LONGEST pos_atr (struct value *);
212
3cb382c9 213static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 214
d2e4a39e 215static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 216
4c4b4cd2
PH
217static struct symbol *standard_lookup (const char *, const struct block *,
218 domain_enum);
14f9c5c9 219
4c4b4cd2
PH
220static struct value *ada_search_struct_field (char *, struct value *, int,
221 struct type *);
222
223static struct value *ada_value_primitive_field (struct value *, int, int,
224 struct type *);
225
0d5cff50 226static int find_struct_field (const char *, struct type *, int,
52ce6436 227 struct type **, int *, int *, int *, int *);
4c4b4cd2
PH
228
229static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
230 struct value *);
231
4c4b4cd2
PH
232static int ada_resolve_function (struct ada_symbol_info *, int,
233 struct value **, int, const char *,
234 struct type *);
235
4c4b4cd2
PH
236static int ada_is_direct_array_type (struct type *);
237
72d5681a
PH
238static void ada_language_arch_info (struct gdbarch *,
239 struct language_arch_info *);
714e53ab
PH
240
241static void check_size (const struct type *);
52ce6436
PH
242
243static struct value *ada_index_struct_field (int, struct value *, int,
244 struct type *);
245
246static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
247 struct expression *,
248 int *, enum noside);
52ce6436
PH
249
250static void aggregate_assign_from_choices (struct value *, struct value *,
251 struct expression *,
252 int *, LONGEST *, int *,
253 int, LONGEST, LONGEST);
254
255static void aggregate_assign_positional (struct value *, struct value *,
256 struct expression *,
257 int *, LONGEST *, int *, int,
258 LONGEST, LONGEST);
259
260
261static void aggregate_assign_others (struct value *, struct value *,
262 struct expression *,
263 int *, LONGEST *, int, LONGEST, LONGEST);
264
265
266static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
267
268
269static struct value *ada_evaluate_subexp (struct type *, struct expression *,
270 int *, enum noside);
271
272static void ada_forward_operator_length (struct expression *, int, int *,
273 int *);
852dff6c
JB
274
275static struct type *ada_find_any_type (const char *name);
4c4b4cd2
PH
276\f
277
76a01679 278
4c4b4cd2 279/* Maximum-sized dynamic type. */
14f9c5c9
AS
280static unsigned int varsize_limit;
281
4c4b4cd2
PH
282/* FIXME: brobecker/2003-09-17: No longer a const because it is
283 returned by a function that does not return a const char *. */
284static char *ada_completer_word_break_characters =
285#ifdef VMS
286 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
287#else
14f9c5c9 288 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 289#endif
14f9c5c9 290
4c4b4cd2 291/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 292static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 293 = "__gnat_ada_main_program_name";
14f9c5c9 294
4c4b4cd2
PH
295/* Limit on the number of warnings to raise per expression evaluation. */
296static int warning_limit = 2;
297
298/* Number of warning messages issued; reset to 0 by cleanups after
299 expression evaluation. */
300static int warnings_issued = 0;
301
302static const char *known_runtime_file_name_patterns[] = {
303 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
304};
305
306static const char *known_auxiliary_function_name_patterns[] = {
307 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
308};
309
310/* Space for allocating results of ada_lookup_symbol_list. */
311static struct obstack symbol_list_obstack;
312
e802dbe0
JB
313 /* Inferior-specific data. */
314
315/* Per-inferior data for this module. */
316
317struct ada_inferior_data
318{
319 /* The ada__tags__type_specific_data type, which is used when decoding
320 tagged types. With older versions of GNAT, this type was directly
321 accessible through a component ("tsd") in the object tag. But this
322 is no longer the case, so we cache it for each inferior. */
323 struct type *tsd_type;
3eecfa55
JB
324
325 /* The exception_support_info data. This data is used to determine
326 how to implement support for Ada exception catchpoints in a given
327 inferior. */
328 const struct exception_support_info *exception_info;
e802dbe0
JB
329};
330
331/* Our key to this module's inferior data. */
332static const struct inferior_data *ada_inferior_data;
333
334/* A cleanup routine for our inferior data. */
335static void
336ada_inferior_data_cleanup (struct inferior *inf, void *arg)
337{
338 struct ada_inferior_data *data;
339
340 data = inferior_data (inf, ada_inferior_data);
341 if (data != NULL)
342 xfree (data);
343}
344
345/* Return our inferior data for the given inferior (INF).
346
347 This function always returns a valid pointer to an allocated
348 ada_inferior_data structure. If INF's inferior data has not
349 been previously set, this functions creates a new one with all
350 fields set to zero, sets INF's inferior to it, and then returns
351 a pointer to that newly allocated ada_inferior_data. */
352
353static struct ada_inferior_data *
354get_ada_inferior_data (struct inferior *inf)
355{
356 struct ada_inferior_data *data;
357
358 data = inferior_data (inf, ada_inferior_data);
359 if (data == NULL)
360 {
361 data = XZALLOC (struct ada_inferior_data);
362 set_inferior_data (inf, ada_inferior_data, data);
363 }
364
365 return data;
366}
367
368/* Perform all necessary cleanups regarding our module's inferior data
369 that is required after the inferior INF just exited. */
370
371static void
372ada_inferior_exit (struct inferior *inf)
373{
374 ada_inferior_data_cleanup (inf, NULL);
375 set_inferior_data (inf, ada_inferior_data, NULL);
376}
377
4c4b4cd2
PH
378 /* Utilities */
379
720d1a40 380/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
eed9788b 381 all typedef layers have been peeled. Otherwise, return TYPE.
720d1a40
JB
382
383 Normally, we really expect a typedef type to only have 1 typedef layer.
384 In other words, we really expect the target type of a typedef type to be
385 a non-typedef type. This is particularly true for Ada units, because
386 the language does not have a typedef vs not-typedef distinction.
387 In that respect, the Ada compiler has been trying to eliminate as many
388 typedef definitions in the debugging information, since they generally
389 do not bring any extra information (we still use typedef under certain
390 circumstances related mostly to the GNAT encoding).
391
392 Unfortunately, we have seen situations where the debugging information
393 generated by the compiler leads to such multiple typedef layers. For
394 instance, consider the following example with stabs:
395
396 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
397 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
398
399 This is an error in the debugging information which causes type
400 pck__float_array___XUP to be defined twice, and the second time,
401 it is defined as a typedef of a typedef.
402
403 This is on the fringe of legality as far as debugging information is
404 concerned, and certainly unexpected. But it is easy to handle these
405 situations correctly, so we can afford to be lenient in this case. */
406
407static struct type *
408ada_typedef_target_type (struct type *type)
409{
410 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
411 type = TYPE_TARGET_TYPE (type);
412 return type;
413}
414
41d27058
JB
415/* Given DECODED_NAME a string holding a symbol name in its
416 decoded form (ie using the Ada dotted notation), returns
417 its unqualified name. */
418
419static const char *
420ada_unqualified_name (const char *decoded_name)
421{
422 const char *result = strrchr (decoded_name, '.');
423
424 if (result != NULL)
425 result++; /* Skip the dot... */
426 else
427 result = decoded_name;
428
429 return result;
430}
431
432/* Return a string starting with '<', followed by STR, and '>'.
433 The result is good until the next call. */
434
435static char *
436add_angle_brackets (const char *str)
437{
438 static char *result = NULL;
439
440 xfree (result);
88c15c34 441 result = xstrprintf ("<%s>", str);
41d27058
JB
442 return result;
443}
96d887e8 444
4c4b4cd2
PH
445static char *
446ada_get_gdb_completer_word_break_characters (void)
447{
448 return ada_completer_word_break_characters;
449}
450
e79af960
JB
451/* Print an array element index using the Ada syntax. */
452
453static void
454ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 455 const struct value_print_options *options)
e79af960 456{
79a45b7d 457 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
458 fprintf_filtered (stream, " => ");
459}
460
f27cf670 461/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 462 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 463 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 464
f27cf670
AS
465void *
466grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 467{
d2e4a39e
AS
468 if (*size < min_size)
469 {
470 *size *= 2;
471 if (*size < min_size)
4c4b4cd2 472 *size = min_size;
f27cf670 473 vect = xrealloc (vect, *size * element_size);
d2e4a39e 474 }
f27cf670 475 return vect;
14f9c5c9
AS
476}
477
478/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 479 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
480
481static int
ebf56fd3 482field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
483{
484 int len = strlen (target);
5b4ee69b 485
d2e4a39e 486 return
4c4b4cd2
PH
487 (strncmp (field_name, target, len) == 0
488 && (field_name[len] == '\0'
489 || (strncmp (field_name + len, "___", 3) == 0
76a01679
JB
490 && strcmp (field_name + strlen (field_name) - 6,
491 "___XVN") != 0)));
14f9c5c9
AS
492}
493
494
872c8b51
JB
495/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
496 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
497 and return its index. This function also handles fields whose name
498 have ___ suffixes because the compiler sometimes alters their name
499 by adding such a suffix to represent fields with certain constraints.
500 If the field could not be found, return a negative number if
501 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
502
503int
504ada_get_field_index (const struct type *type, const char *field_name,
505 int maybe_missing)
506{
507 int fieldno;
872c8b51
JB
508 struct type *struct_type = check_typedef ((struct type *) type);
509
510 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
511 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
512 return fieldno;
513
514 if (!maybe_missing)
323e0a4a 515 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 516 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
517
518 return -1;
519}
520
521/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
522
523int
d2e4a39e 524ada_name_prefix_len (const char *name)
14f9c5c9
AS
525{
526 if (name == NULL)
527 return 0;
d2e4a39e 528 else
14f9c5c9 529 {
d2e4a39e 530 const char *p = strstr (name, "___");
5b4ee69b 531
14f9c5c9 532 if (p == NULL)
4c4b4cd2 533 return strlen (name);
14f9c5c9 534 else
4c4b4cd2 535 return p - name;
14f9c5c9
AS
536 }
537}
538
4c4b4cd2
PH
539/* Return non-zero if SUFFIX is a suffix of STR.
540 Return zero if STR is null. */
541
14f9c5c9 542static int
d2e4a39e 543is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
544{
545 int len1, len2;
5b4ee69b 546
14f9c5c9
AS
547 if (str == NULL)
548 return 0;
549 len1 = strlen (str);
550 len2 = strlen (suffix);
4c4b4cd2 551 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
552}
553
4c4b4cd2
PH
554/* The contents of value VAL, treated as a value of type TYPE. The
555 result is an lval in memory if VAL is. */
14f9c5c9 556
d2e4a39e 557static struct value *
4c4b4cd2 558coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 559{
61ee279c 560 type = ada_check_typedef (type);
df407dfe 561 if (value_type (val) == type)
4c4b4cd2 562 return val;
d2e4a39e 563 else
14f9c5c9 564 {
4c4b4cd2
PH
565 struct value *result;
566
567 /* Make sure that the object size is not unreasonable before
568 trying to allocate some memory for it. */
714e53ab 569 check_size (type);
4c4b4cd2 570
41e8491f
JK
571 if (value_lazy (val)
572 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
573 result = allocate_value_lazy (type);
574 else
575 {
576 result = allocate_value (type);
577 memcpy (value_contents_raw (result), value_contents (val),
578 TYPE_LENGTH (type));
579 }
74bcbdf3 580 set_value_component_location (result, val);
9bbda503
AC
581 set_value_bitsize (result, value_bitsize (val));
582 set_value_bitpos (result, value_bitpos (val));
42ae5230 583 set_value_address (result, value_address (val));
2fa15f23 584 set_value_optimized_out (result, value_optimized_out (val));
14f9c5c9
AS
585 return result;
586 }
587}
588
fc1a4b47
AC
589static const gdb_byte *
590cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
591{
592 if (valaddr == NULL)
593 return NULL;
594 else
595 return valaddr + offset;
596}
597
598static CORE_ADDR
ebf56fd3 599cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
600{
601 if (address == 0)
602 return 0;
d2e4a39e 603 else
14f9c5c9
AS
604 return address + offset;
605}
606
4c4b4cd2
PH
607/* Issue a warning (as for the definition of warning in utils.c, but
608 with exactly one argument rather than ...), unless the limit on the
609 number of warnings has passed during the evaluation of the current
610 expression. */
a2249542 611
77109804
AC
612/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
613 provided by "complaint". */
a0b31db1 614static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 615
14f9c5c9 616static void
a2249542 617lim_warning (const char *format, ...)
14f9c5c9 618{
a2249542 619 va_list args;
a2249542 620
5b4ee69b 621 va_start (args, format);
4c4b4cd2
PH
622 warnings_issued += 1;
623 if (warnings_issued <= warning_limit)
a2249542
MK
624 vwarning (format, args);
625
626 va_end (args);
4c4b4cd2
PH
627}
628
714e53ab
PH
629/* Issue an error if the size of an object of type T is unreasonable,
630 i.e. if it would be a bad idea to allocate a value of this type in
631 GDB. */
632
633static void
634check_size (const struct type *type)
635{
636 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 637 error (_("object size is larger than varsize-limit"));
714e53ab
PH
638}
639
0963b4bd 640/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 641static LONGEST
c3e5cd34 642max_of_size (int size)
4c4b4cd2 643{
76a01679 644 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 645
76a01679 646 return top_bit | (top_bit - 1);
4c4b4cd2
PH
647}
648
0963b4bd 649/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 650static LONGEST
c3e5cd34 651min_of_size (int size)
4c4b4cd2 652{
c3e5cd34 653 return -max_of_size (size) - 1;
4c4b4cd2
PH
654}
655
0963b4bd 656/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 657static ULONGEST
c3e5cd34 658umax_of_size (int size)
4c4b4cd2 659{
76a01679 660 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 661
76a01679 662 return top_bit | (top_bit - 1);
4c4b4cd2
PH
663}
664
0963b4bd 665/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
666static LONGEST
667max_of_type (struct type *t)
4c4b4cd2 668{
c3e5cd34
PH
669 if (TYPE_UNSIGNED (t))
670 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
671 else
672 return max_of_size (TYPE_LENGTH (t));
673}
674
0963b4bd 675/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
676static LONGEST
677min_of_type (struct type *t)
678{
679 if (TYPE_UNSIGNED (t))
680 return 0;
681 else
682 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
683}
684
685/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
686LONGEST
687ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 688{
76a01679 689 switch (TYPE_CODE (type))
4c4b4cd2
PH
690 {
691 case TYPE_CODE_RANGE:
690cc4eb 692 return TYPE_HIGH_BOUND (type);
4c4b4cd2 693 case TYPE_CODE_ENUM:
14e75d8e 694 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
695 case TYPE_CODE_BOOL:
696 return 1;
697 case TYPE_CODE_CHAR:
76a01679 698 case TYPE_CODE_INT:
690cc4eb 699 return max_of_type (type);
4c4b4cd2 700 default:
43bbcdc2 701 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
702 }
703}
704
14e75d8e 705/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
706LONGEST
707ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 708{
76a01679 709 switch (TYPE_CODE (type))
4c4b4cd2
PH
710 {
711 case TYPE_CODE_RANGE:
690cc4eb 712 return TYPE_LOW_BOUND (type);
4c4b4cd2 713 case TYPE_CODE_ENUM:
14e75d8e 714 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
715 case TYPE_CODE_BOOL:
716 return 0;
717 case TYPE_CODE_CHAR:
76a01679 718 case TYPE_CODE_INT:
690cc4eb 719 return min_of_type (type);
4c4b4cd2 720 default:
43bbcdc2 721 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
722 }
723}
724
725/* The identity on non-range types. For range types, the underlying
76a01679 726 non-range scalar type. */
4c4b4cd2
PH
727
728static struct type *
18af8284 729get_base_type (struct type *type)
4c4b4cd2
PH
730{
731 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
732 {
76a01679
JB
733 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
734 return type;
4c4b4cd2
PH
735 type = TYPE_TARGET_TYPE (type);
736 }
737 return type;
14f9c5c9 738}
41246937
JB
739
740/* Return a decoded version of the given VALUE. This means returning
741 a value whose type is obtained by applying all the GNAT-specific
742 encondings, making the resulting type a static but standard description
743 of the initial type. */
744
745struct value *
746ada_get_decoded_value (struct value *value)
747{
748 struct type *type = ada_check_typedef (value_type (value));
749
750 if (ada_is_array_descriptor_type (type)
751 || (ada_is_constrained_packed_array_type (type)
752 && TYPE_CODE (type) != TYPE_CODE_PTR))
753 {
754 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
755 value = ada_coerce_to_simple_array_ptr (value);
756 else
757 value = ada_coerce_to_simple_array (value);
758 }
759 else
760 value = ada_to_fixed_value (value);
761
762 return value;
763}
764
765/* Same as ada_get_decoded_value, but with the given TYPE.
766 Because there is no associated actual value for this type,
767 the resulting type might be a best-effort approximation in
768 the case of dynamic types. */
769
770struct type *
771ada_get_decoded_type (struct type *type)
772{
773 type = to_static_fixed_type (type);
774 if (ada_is_constrained_packed_array_type (type))
775 type = ada_coerce_to_simple_array_type (type);
776 return type;
777}
778
4c4b4cd2 779\f
76a01679 780
4c4b4cd2 781 /* Language Selection */
14f9c5c9
AS
782
783/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 784 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 785
14f9c5c9 786enum language
ccefe4c4 787ada_update_initial_language (enum language lang)
14f9c5c9 788{
d2e4a39e 789 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
4c4b4cd2
PH
790 (struct objfile *) NULL) != NULL)
791 return language_ada;
14f9c5c9
AS
792
793 return lang;
794}
96d887e8
PH
795
796/* If the main procedure is written in Ada, then return its name.
797 The result is good until the next call. Return NULL if the main
798 procedure doesn't appear to be in Ada. */
799
800char *
801ada_main_name (void)
802{
803 struct minimal_symbol *msym;
f9bc20b9 804 static char *main_program_name = NULL;
6c038f32 805
96d887e8
PH
806 /* For Ada, the name of the main procedure is stored in a specific
807 string constant, generated by the binder. Look for that symbol,
808 extract its address, and then read that string. If we didn't find
809 that string, then most probably the main procedure is not written
810 in Ada. */
811 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
812
813 if (msym != NULL)
814 {
f9bc20b9
JB
815 CORE_ADDR main_program_name_addr;
816 int err_code;
817
96d887e8
PH
818 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
819 if (main_program_name_addr == 0)
323e0a4a 820 error (_("Invalid address for Ada main program name."));
96d887e8 821
f9bc20b9
JB
822 xfree (main_program_name);
823 target_read_string (main_program_name_addr, &main_program_name,
824 1024, &err_code);
825
826 if (err_code != 0)
827 return NULL;
96d887e8
PH
828 return main_program_name;
829 }
830
831 /* The main procedure doesn't seem to be in Ada. */
832 return NULL;
833}
14f9c5c9 834\f
4c4b4cd2 835 /* Symbols */
d2e4a39e 836
4c4b4cd2
PH
837/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
838 of NULLs. */
14f9c5c9 839
d2e4a39e
AS
840const struct ada_opname_map ada_opname_table[] = {
841 {"Oadd", "\"+\"", BINOP_ADD},
842 {"Osubtract", "\"-\"", BINOP_SUB},
843 {"Omultiply", "\"*\"", BINOP_MUL},
844 {"Odivide", "\"/\"", BINOP_DIV},
845 {"Omod", "\"mod\"", BINOP_MOD},
846 {"Orem", "\"rem\"", BINOP_REM},
847 {"Oexpon", "\"**\"", BINOP_EXP},
848 {"Olt", "\"<\"", BINOP_LESS},
849 {"Ole", "\"<=\"", BINOP_LEQ},
850 {"Ogt", "\">\"", BINOP_GTR},
851 {"Oge", "\">=\"", BINOP_GEQ},
852 {"Oeq", "\"=\"", BINOP_EQUAL},
853 {"One", "\"/=\"", BINOP_NOTEQUAL},
854 {"Oand", "\"and\"", BINOP_BITWISE_AND},
855 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
856 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
857 {"Oconcat", "\"&\"", BINOP_CONCAT},
858 {"Oabs", "\"abs\"", UNOP_ABS},
859 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
860 {"Oadd", "\"+\"", UNOP_PLUS},
861 {"Osubtract", "\"-\"", UNOP_NEG},
862 {NULL, NULL}
14f9c5c9
AS
863};
864
4c4b4cd2
PH
865/* The "encoded" form of DECODED, according to GNAT conventions.
866 The result is valid until the next call to ada_encode. */
867
14f9c5c9 868char *
4c4b4cd2 869ada_encode (const char *decoded)
14f9c5c9 870{
4c4b4cd2
PH
871 static char *encoding_buffer = NULL;
872 static size_t encoding_buffer_size = 0;
d2e4a39e 873 const char *p;
14f9c5c9 874 int k;
d2e4a39e 875
4c4b4cd2 876 if (decoded == NULL)
14f9c5c9
AS
877 return NULL;
878
4c4b4cd2
PH
879 GROW_VECT (encoding_buffer, encoding_buffer_size,
880 2 * strlen (decoded) + 10);
14f9c5c9
AS
881
882 k = 0;
4c4b4cd2 883 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 884 {
cdc7bb92 885 if (*p == '.')
4c4b4cd2
PH
886 {
887 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
888 k += 2;
889 }
14f9c5c9 890 else if (*p == '"')
4c4b4cd2
PH
891 {
892 const struct ada_opname_map *mapping;
893
894 for (mapping = ada_opname_table;
1265e4aa
JB
895 mapping->encoded != NULL
896 && strncmp (mapping->decoded, p,
897 strlen (mapping->decoded)) != 0; mapping += 1)
4c4b4cd2
PH
898 ;
899 if (mapping->encoded == NULL)
323e0a4a 900 error (_("invalid Ada operator name: %s"), p);
4c4b4cd2
PH
901 strcpy (encoding_buffer + k, mapping->encoded);
902 k += strlen (mapping->encoded);
903 break;
904 }
d2e4a39e 905 else
4c4b4cd2
PH
906 {
907 encoding_buffer[k] = *p;
908 k += 1;
909 }
14f9c5c9
AS
910 }
911
4c4b4cd2
PH
912 encoding_buffer[k] = '\0';
913 return encoding_buffer;
14f9c5c9
AS
914}
915
916/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
917 quotes, unfolded, but with the quotes stripped away. Result good
918 to next call. */
919
d2e4a39e
AS
920char *
921ada_fold_name (const char *name)
14f9c5c9 922{
d2e4a39e 923 static char *fold_buffer = NULL;
14f9c5c9
AS
924 static size_t fold_buffer_size = 0;
925
926 int len = strlen (name);
d2e4a39e 927 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
928
929 if (name[0] == '\'')
930 {
d2e4a39e
AS
931 strncpy (fold_buffer, name + 1, len - 2);
932 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
933 }
934 else
935 {
936 int i;
5b4ee69b 937
14f9c5c9 938 for (i = 0; i <= len; i += 1)
4c4b4cd2 939 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
940 }
941
942 return fold_buffer;
943}
944
529cad9c
PH
945/* Return nonzero if C is either a digit or a lowercase alphabet character. */
946
947static int
948is_lower_alphanum (const char c)
949{
950 return (isdigit (c) || (isalpha (c) && islower (c)));
951}
952
c90092fe
JB
953/* ENCODED is the linkage name of a symbol and LEN contains its length.
954 This function saves in LEN the length of that same symbol name but
955 without either of these suffixes:
29480c32
JB
956 . .{DIGIT}+
957 . ${DIGIT}+
958 . ___{DIGIT}+
959 . __{DIGIT}+.
c90092fe 960
29480c32
JB
961 These are suffixes introduced by the compiler for entities such as
962 nested subprogram for instance, in order to avoid name clashes.
963 They do not serve any purpose for the debugger. */
964
965static void
966ada_remove_trailing_digits (const char *encoded, int *len)
967{
968 if (*len > 1 && isdigit (encoded[*len - 1]))
969 {
970 int i = *len - 2;
5b4ee69b 971
29480c32
JB
972 while (i > 0 && isdigit (encoded[i]))
973 i--;
974 if (i >= 0 && encoded[i] == '.')
975 *len = i;
976 else if (i >= 0 && encoded[i] == '$')
977 *len = i;
978 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
979 *len = i - 2;
980 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
981 *len = i - 1;
982 }
983}
984
985/* Remove the suffix introduced by the compiler for protected object
986 subprograms. */
987
988static void
989ada_remove_po_subprogram_suffix (const char *encoded, int *len)
990{
991 /* Remove trailing N. */
992
993 /* Protected entry subprograms are broken into two
994 separate subprograms: The first one is unprotected, and has
995 a 'N' suffix; the second is the protected version, and has
0963b4bd 996 the 'P' suffix. The second calls the first one after handling
29480c32
JB
997 the protection. Since the P subprograms are internally generated,
998 we leave these names undecoded, giving the user a clue that this
999 entity is internal. */
1000
1001 if (*len > 1
1002 && encoded[*len - 1] == 'N'
1003 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1004 *len = *len - 1;
1005}
1006
69fadcdf
JB
1007/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1008
1009static void
1010ada_remove_Xbn_suffix (const char *encoded, int *len)
1011{
1012 int i = *len - 1;
1013
1014 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1015 i--;
1016
1017 if (encoded[i] != 'X')
1018 return;
1019
1020 if (i == 0)
1021 return;
1022
1023 if (isalnum (encoded[i-1]))
1024 *len = i;
1025}
1026
29480c32
JB
1027/* If ENCODED follows the GNAT entity encoding conventions, then return
1028 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1029 replaced by ENCODED.
14f9c5c9 1030
4c4b4cd2 1031 The resulting string is valid until the next call of ada_decode.
29480c32 1032 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1033 is returned. */
1034
1035const char *
1036ada_decode (const char *encoded)
14f9c5c9
AS
1037{
1038 int i, j;
1039 int len0;
d2e4a39e 1040 const char *p;
4c4b4cd2 1041 char *decoded;
14f9c5c9 1042 int at_start_name;
4c4b4cd2
PH
1043 static char *decoding_buffer = NULL;
1044 static size_t decoding_buffer_size = 0;
d2e4a39e 1045
29480c32
JB
1046 /* The name of the Ada main procedure starts with "_ada_".
1047 This prefix is not part of the decoded name, so skip this part
1048 if we see this prefix. */
4c4b4cd2
PH
1049 if (strncmp (encoded, "_ada_", 5) == 0)
1050 encoded += 5;
14f9c5c9 1051
29480c32
JB
1052 /* If the name starts with '_', then it is not a properly encoded
1053 name, so do not attempt to decode it. Similarly, if the name
1054 starts with '<', the name should not be decoded. */
4c4b4cd2 1055 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1056 goto Suppress;
1057
4c4b4cd2 1058 len0 = strlen (encoded);
4c4b4cd2 1059
29480c32
JB
1060 ada_remove_trailing_digits (encoded, &len0);
1061 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1062
4c4b4cd2
PH
1063 /* Remove the ___X.* suffix if present. Do not forget to verify that
1064 the suffix is located before the current "end" of ENCODED. We want
1065 to avoid re-matching parts of ENCODED that have previously been
1066 marked as discarded (by decrementing LEN0). */
1067 p = strstr (encoded, "___");
1068 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1069 {
1070 if (p[3] == 'X')
4c4b4cd2 1071 len0 = p - encoded;
14f9c5c9 1072 else
4c4b4cd2 1073 goto Suppress;
14f9c5c9 1074 }
4c4b4cd2 1075
29480c32
JB
1076 /* Remove any trailing TKB suffix. It tells us that this symbol
1077 is for the body of a task, but that information does not actually
1078 appear in the decoded name. */
1079
4c4b4cd2 1080 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
14f9c5c9 1081 len0 -= 3;
76a01679 1082
a10967fa
JB
1083 /* Remove any trailing TB suffix. The TB suffix is slightly different
1084 from the TKB suffix because it is used for non-anonymous task
1085 bodies. */
1086
1087 if (len0 > 2 && strncmp (encoded + len0 - 2, "TB", 2) == 0)
1088 len0 -= 2;
1089
29480c32
JB
1090 /* Remove trailing "B" suffixes. */
1091 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1092
4c4b4cd2 1093 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
14f9c5c9
AS
1094 len0 -= 1;
1095
4c4b4cd2 1096 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1097
4c4b4cd2
PH
1098 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1099 decoded = decoding_buffer;
14f9c5c9 1100
29480c32
JB
1101 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1102
4c4b4cd2 1103 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1104 {
4c4b4cd2
PH
1105 i = len0 - 2;
1106 while ((i >= 0 && isdigit (encoded[i]))
1107 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1108 i -= 1;
1109 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1110 len0 = i - 1;
1111 else if (encoded[i] == '$')
1112 len0 = i;
d2e4a39e 1113 }
14f9c5c9 1114
29480c32
JB
1115 /* The first few characters that are not alphabetic are not part
1116 of any encoding we use, so we can copy them over verbatim. */
1117
4c4b4cd2
PH
1118 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1119 decoded[j] = encoded[i];
14f9c5c9
AS
1120
1121 at_start_name = 1;
1122 while (i < len0)
1123 {
29480c32 1124 /* Is this a symbol function? */
4c4b4cd2
PH
1125 if (at_start_name && encoded[i] == 'O')
1126 {
1127 int k;
5b4ee69b 1128
4c4b4cd2
PH
1129 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1130 {
1131 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1132 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1133 op_len - 1) == 0)
1134 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1135 {
1136 strcpy (decoded + j, ada_opname_table[k].decoded);
1137 at_start_name = 0;
1138 i += op_len;
1139 j += strlen (ada_opname_table[k].decoded);
1140 break;
1141 }
1142 }
1143 if (ada_opname_table[k].encoded != NULL)
1144 continue;
1145 }
14f9c5c9
AS
1146 at_start_name = 0;
1147
529cad9c
PH
1148 /* Replace "TK__" with "__", which will eventually be translated
1149 into "." (just below). */
1150
4c4b4cd2
PH
1151 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
1152 i += 2;
529cad9c 1153
29480c32
JB
1154 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1155 be translated into "." (just below). These are internal names
1156 generated for anonymous blocks inside which our symbol is nested. */
1157
1158 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1159 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1160 && isdigit (encoded [i+4]))
1161 {
1162 int k = i + 5;
1163
1164 while (k < len0 && isdigit (encoded[k]))
1165 k++; /* Skip any extra digit. */
1166
1167 /* Double-check that the "__B_{DIGITS}+" sequence we found
1168 is indeed followed by "__". */
1169 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1170 i = k;
1171 }
1172
529cad9c
PH
1173 /* Remove _E{DIGITS}+[sb] */
1174
1175 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1176 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1177 one implements the actual entry code, and has a suffix following
1178 the convention above; the second one implements the barrier and
1179 uses the same convention as above, except that the 'E' is replaced
1180 by a 'B'.
1181
1182 Just as above, we do not decode the name of barrier functions
1183 to give the user a clue that the code he is debugging has been
1184 internally generated. */
1185
1186 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1187 && isdigit (encoded[i+2]))
1188 {
1189 int k = i + 3;
1190
1191 while (k < len0 && isdigit (encoded[k]))
1192 k++;
1193
1194 if (k < len0
1195 && (encoded[k] == 'b' || encoded[k] == 's'))
1196 {
1197 k++;
1198 /* Just as an extra precaution, make sure that if this
1199 suffix is followed by anything else, it is a '_'.
1200 Otherwise, we matched this sequence by accident. */
1201 if (k == len0
1202 || (k < len0 && encoded[k] == '_'))
1203 i = k;
1204 }
1205 }
1206
1207 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1208 the GNAT front-end in protected object subprograms. */
1209
1210 if (i < len0 + 3
1211 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1212 {
1213 /* Backtrack a bit up until we reach either the begining of
1214 the encoded name, or "__". Make sure that we only find
1215 digits or lowercase characters. */
1216 const char *ptr = encoded + i - 1;
1217
1218 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1219 ptr--;
1220 if (ptr < encoded
1221 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1222 i++;
1223 }
1224
4c4b4cd2
PH
1225 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1226 {
29480c32
JB
1227 /* This is a X[bn]* sequence not separated from the previous
1228 part of the name with a non-alpha-numeric character (in other
1229 words, immediately following an alpha-numeric character), then
1230 verify that it is placed at the end of the encoded name. If
1231 not, then the encoding is not valid and we should abort the
1232 decoding. Otherwise, just skip it, it is used in body-nested
1233 package names. */
4c4b4cd2
PH
1234 do
1235 i += 1;
1236 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1237 if (i < len0)
1238 goto Suppress;
1239 }
cdc7bb92 1240 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1241 {
29480c32 1242 /* Replace '__' by '.'. */
4c4b4cd2
PH
1243 decoded[j] = '.';
1244 at_start_name = 1;
1245 i += 2;
1246 j += 1;
1247 }
14f9c5c9 1248 else
4c4b4cd2 1249 {
29480c32
JB
1250 /* It's a character part of the decoded name, so just copy it
1251 over. */
4c4b4cd2
PH
1252 decoded[j] = encoded[i];
1253 i += 1;
1254 j += 1;
1255 }
14f9c5c9 1256 }
4c4b4cd2 1257 decoded[j] = '\000';
14f9c5c9 1258
29480c32
JB
1259 /* Decoded names should never contain any uppercase character.
1260 Double-check this, and abort the decoding if we find one. */
1261
4c4b4cd2
PH
1262 for (i = 0; decoded[i] != '\0'; i += 1)
1263 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1264 goto Suppress;
1265
4c4b4cd2
PH
1266 if (strcmp (decoded, encoded) == 0)
1267 return encoded;
1268 else
1269 return decoded;
14f9c5c9
AS
1270
1271Suppress:
4c4b4cd2
PH
1272 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1273 decoded = decoding_buffer;
1274 if (encoded[0] == '<')
1275 strcpy (decoded, encoded);
14f9c5c9 1276 else
88c15c34 1277 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1278 return decoded;
1279
1280}
1281
1282/* Table for keeping permanent unique copies of decoded names. Once
1283 allocated, names in this table are never released. While this is a
1284 storage leak, it should not be significant unless there are massive
1285 changes in the set of decoded names in successive versions of a
1286 symbol table loaded during a single session. */
1287static struct htab *decoded_names_store;
1288
1289/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1290 in the language-specific part of GSYMBOL, if it has not been
1291 previously computed. Tries to save the decoded name in the same
1292 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1293 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1294 GSYMBOL).
4c4b4cd2
PH
1295 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1296 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1297 when a decoded name is cached in it. */
4c4b4cd2 1298
45e6c716 1299const char *
f85f34ed 1300ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1301{
f85f34ed
TT
1302 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1303 const char **resultp =
1304 &gsymbol->language_specific.mangled_lang.demangled_name;
5b4ee69b 1305
f85f34ed 1306 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1307 {
1308 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1309 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1310
f85f34ed 1311 gsymbol->ada_mangled = 1;
5b4ee69b 1312
f85f34ed
TT
1313 if (obstack != NULL)
1314 *resultp = obstack_copy0 (obstack, decoded, strlen (decoded));
1315 else
76a01679 1316 {
f85f34ed
TT
1317 /* Sometimes, we can't find a corresponding objfile, in
1318 which case, we put the result on the heap. Since we only
1319 decode when needed, we hope this usually does not cause a
1320 significant memory leak (FIXME). */
1321
76a01679
JB
1322 char **slot = (char **) htab_find_slot (decoded_names_store,
1323 decoded, INSERT);
5b4ee69b 1324
76a01679
JB
1325 if (*slot == NULL)
1326 *slot = xstrdup (decoded);
1327 *resultp = *slot;
1328 }
4c4b4cd2 1329 }
14f9c5c9 1330
4c4b4cd2
PH
1331 return *resultp;
1332}
76a01679 1333
2c0b251b 1334static char *
76a01679 1335ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1336{
1337 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1338}
1339
1340/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
4c4b4cd2
PH
1341 suffixes that encode debugging information or leading _ada_ on
1342 SYM_NAME (see is_name_suffix commentary for the debugging
1343 information that is ignored). If WILD, then NAME need only match a
1344 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1345 either argument is NULL. */
14f9c5c9 1346
2c0b251b 1347static int
40658b94 1348match_name (const char *sym_name, const char *name, int wild)
14f9c5c9
AS
1349{
1350 if (sym_name == NULL || name == NULL)
1351 return 0;
1352 else if (wild)
73589123 1353 return wild_match (sym_name, name) == 0;
d2e4a39e
AS
1354 else
1355 {
1356 int len_name = strlen (name);
5b4ee69b 1357
4c4b4cd2
PH
1358 return (strncmp (sym_name, name, len_name) == 0
1359 && is_name_suffix (sym_name + len_name))
1360 || (strncmp (sym_name, "_ada_", 5) == 0
1361 && strncmp (sym_name + 5, name, len_name) == 0
1362 && is_name_suffix (sym_name + len_name + 5));
d2e4a39e 1363 }
14f9c5c9 1364}
14f9c5c9 1365\f
d2e4a39e 1366
4c4b4cd2 1367 /* Arrays */
14f9c5c9 1368
28c85d6c
JB
1369/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1370 generated by the GNAT compiler to describe the index type used
1371 for each dimension of an array, check whether it follows the latest
1372 known encoding. If not, fix it up to conform to the latest encoding.
1373 Otherwise, do nothing. This function also does nothing if
1374 INDEX_DESC_TYPE is NULL.
1375
1376 The GNAT encoding used to describle the array index type evolved a bit.
1377 Initially, the information would be provided through the name of each
1378 field of the structure type only, while the type of these fields was
1379 described as unspecified and irrelevant. The debugger was then expected
1380 to perform a global type lookup using the name of that field in order
1381 to get access to the full index type description. Because these global
1382 lookups can be very expensive, the encoding was later enhanced to make
1383 the global lookup unnecessary by defining the field type as being
1384 the full index type description.
1385
1386 The purpose of this routine is to allow us to support older versions
1387 of the compiler by detecting the use of the older encoding, and by
1388 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1389 we essentially replace each field's meaningless type by the associated
1390 index subtype). */
1391
1392void
1393ada_fixup_array_indexes_type (struct type *index_desc_type)
1394{
1395 int i;
1396
1397 if (index_desc_type == NULL)
1398 return;
1399 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1400
1401 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1402 to check one field only, no need to check them all). If not, return
1403 now.
1404
1405 If our INDEX_DESC_TYPE was generated using the older encoding,
1406 the field type should be a meaningless integer type whose name
1407 is not equal to the field name. */
1408 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1409 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1410 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1411 return;
1412
1413 /* Fixup each field of INDEX_DESC_TYPE. */
1414 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1415 {
0d5cff50 1416 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1417 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1418
1419 if (raw_type)
1420 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1421 }
1422}
1423
4c4b4cd2 1424/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1425
d2e4a39e
AS
1426static char *bound_name[] = {
1427 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1428 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1429};
1430
1431/* Maximum number of array dimensions we are prepared to handle. */
1432
4c4b4cd2 1433#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1434
14f9c5c9 1435
4c4b4cd2
PH
1436/* The desc_* routines return primitive portions of array descriptors
1437 (fat pointers). */
14f9c5c9
AS
1438
1439/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1440 level of indirection, if needed. */
1441
d2e4a39e
AS
1442static struct type *
1443desc_base_type (struct type *type)
14f9c5c9
AS
1444{
1445 if (type == NULL)
1446 return NULL;
61ee279c 1447 type = ada_check_typedef (type);
720d1a40
JB
1448 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1449 type = ada_typedef_target_type (type);
1450
1265e4aa
JB
1451 if (type != NULL
1452 && (TYPE_CODE (type) == TYPE_CODE_PTR
1453 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1454 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1455 else
1456 return type;
1457}
1458
4c4b4cd2
PH
1459/* True iff TYPE indicates a "thin" array pointer type. */
1460
14f9c5c9 1461static int
d2e4a39e 1462is_thin_pntr (struct type *type)
14f9c5c9 1463{
d2e4a39e 1464 return
14f9c5c9
AS
1465 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1466 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1467}
1468
4c4b4cd2
PH
1469/* The descriptor type for thin pointer type TYPE. */
1470
d2e4a39e
AS
1471static struct type *
1472thin_descriptor_type (struct type *type)
14f9c5c9 1473{
d2e4a39e 1474 struct type *base_type = desc_base_type (type);
5b4ee69b 1475
14f9c5c9
AS
1476 if (base_type == NULL)
1477 return NULL;
1478 if (is_suffix (ada_type_name (base_type), "___XVE"))
1479 return base_type;
d2e4a39e 1480 else
14f9c5c9 1481 {
d2e4a39e 1482 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1483
14f9c5c9 1484 if (alt_type == NULL)
4c4b4cd2 1485 return base_type;
14f9c5c9 1486 else
4c4b4cd2 1487 return alt_type;
14f9c5c9
AS
1488 }
1489}
1490
4c4b4cd2
PH
1491/* A pointer to the array data for thin-pointer value VAL. */
1492
d2e4a39e
AS
1493static struct value *
1494thin_data_pntr (struct value *val)
14f9c5c9 1495{
828292f2 1496 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1497 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1498
556bdfd4
UW
1499 data_type = lookup_pointer_type (data_type);
1500
14f9c5c9 1501 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1502 return value_cast (data_type, value_copy (val));
d2e4a39e 1503 else
42ae5230 1504 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1505}
1506
4c4b4cd2
PH
1507/* True iff TYPE indicates a "thick" array pointer type. */
1508
14f9c5c9 1509static int
d2e4a39e 1510is_thick_pntr (struct type *type)
14f9c5c9
AS
1511{
1512 type = desc_base_type (type);
1513 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1514 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1515}
1516
4c4b4cd2
PH
1517/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1518 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1519
d2e4a39e
AS
1520static struct type *
1521desc_bounds_type (struct type *type)
14f9c5c9 1522{
d2e4a39e 1523 struct type *r;
14f9c5c9
AS
1524
1525 type = desc_base_type (type);
1526
1527 if (type == NULL)
1528 return NULL;
1529 else if (is_thin_pntr (type))
1530 {
1531 type = thin_descriptor_type (type);
1532 if (type == NULL)
4c4b4cd2 1533 return NULL;
14f9c5c9
AS
1534 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1535 if (r != NULL)
61ee279c 1536 return ada_check_typedef (r);
14f9c5c9
AS
1537 }
1538 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1539 {
1540 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1541 if (r != NULL)
61ee279c 1542 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1543 }
1544 return NULL;
1545}
1546
1547/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1548 one, a pointer to its bounds data. Otherwise NULL. */
1549
d2e4a39e
AS
1550static struct value *
1551desc_bounds (struct value *arr)
14f9c5c9 1552{
df407dfe 1553 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1554
d2e4a39e 1555 if (is_thin_pntr (type))
14f9c5c9 1556 {
d2e4a39e 1557 struct type *bounds_type =
4c4b4cd2 1558 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1559 LONGEST addr;
1560
4cdfadb1 1561 if (bounds_type == NULL)
323e0a4a 1562 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1563
1564 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1565 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1566 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1567 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1568 addr = value_as_long (arr);
d2e4a39e 1569 else
42ae5230 1570 addr = value_address (arr);
14f9c5c9 1571
d2e4a39e 1572 return
4c4b4cd2
PH
1573 value_from_longest (lookup_pointer_type (bounds_type),
1574 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1575 }
1576
1577 else if (is_thick_pntr (type))
05e522ef
JB
1578 {
1579 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1580 _("Bad GNAT array descriptor"));
1581 struct type *p_bounds_type = value_type (p_bounds);
1582
1583 if (p_bounds_type
1584 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1585 {
1586 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1587
1588 if (TYPE_STUB (target_type))
1589 p_bounds = value_cast (lookup_pointer_type
1590 (ada_check_typedef (target_type)),
1591 p_bounds);
1592 }
1593 else
1594 error (_("Bad GNAT array descriptor"));
1595
1596 return p_bounds;
1597 }
14f9c5c9
AS
1598 else
1599 return NULL;
1600}
1601
4c4b4cd2
PH
1602/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1603 position of the field containing the address of the bounds data. */
1604
14f9c5c9 1605static int
d2e4a39e 1606fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1607{
1608 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1609}
1610
1611/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1612 size of the field containing the address of the bounds data. */
1613
14f9c5c9 1614static int
d2e4a39e 1615fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1616{
1617 type = desc_base_type (type);
1618
d2e4a39e 1619 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1620 return TYPE_FIELD_BITSIZE (type, 1);
1621 else
61ee279c 1622 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1623}
1624
4c4b4cd2 1625/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1626 pointer to one, the type of its array data (a array-with-no-bounds type);
1627 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1628 data. */
4c4b4cd2 1629
d2e4a39e 1630static struct type *
556bdfd4 1631desc_data_target_type (struct type *type)
14f9c5c9
AS
1632{
1633 type = desc_base_type (type);
1634
4c4b4cd2 1635 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1636 if (is_thin_pntr (type))
556bdfd4 1637 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1638 else if (is_thick_pntr (type))
556bdfd4
UW
1639 {
1640 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1641
1642 if (data_type
1643 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1644 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1645 }
1646
1647 return NULL;
14f9c5c9
AS
1648}
1649
1650/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1651 its array data. */
4c4b4cd2 1652
d2e4a39e
AS
1653static struct value *
1654desc_data (struct value *arr)
14f9c5c9 1655{
df407dfe 1656 struct type *type = value_type (arr);
5b4ee69b 1657
14f9c5c9
AS
1658 if (is_thin_pntr (type))
1659 return thin_data_pntr (arr);
1660 else if (is_thick_pntr (type))
d2e4a39e 1661 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1662 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1663 else
1664 return NULL;
1665}
1666
1667
1668/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1669 position of the field containing the address of the data. */
1670
14f9c5c9 1671static int
d2e4a39e 1672fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1673{
1674 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1675}
1676
1677/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1678 size of the field containing the address of the data. */
1679
14f9c5c9 1680static int
d2e4a39e 1681fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1682{
1683 type = desc_base_type (type);
1684
1685 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1686 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1687 else
14f9c5c9
AS
1688 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1689}
1690
4c4b4cd2 1691/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1692 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1693 bound, if WHICH is 1. The first bound is I=1. */
1694
d2e4a39e
AS
1695static struct value *
1696desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1697{
d2e4a39e 1698 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1699 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1700}
1701
1702/* If BOUNDS is an array-bounds structure type, return the bit position
1703 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1704 bound, if WHICH is 1. The first bound is I=1. */
1705
14f9c5c9 1706static int
d2e4a39e 1707desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1708{
d2e4a39e 1709 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1710}
1711
1712/* If BOUNDS is an array-bounds structure type, return the bit field size
1713 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1714 bound, if WHICH is 1. The first bound is I=1. */
1715
76a01679 1716static int
d2e4a39e 1717desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1718{
1719 type = desc_base_type (type);
1720
d2e4a39e
AS
1721 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1722 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1723 else
1724 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1725}
1726
1727/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1728 Ith bound (numbering from 1). Otherwise, NULL. */
1729
d2e4a39e
AS
1730static struct type *
1731desc_index_type (struct type *type, int i)
14f9c5c9
AS
1732{
1733 type = desc_base_type (type);
1734
1735 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1736 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1737 else
14f9c5c9
AS
1738 return NULL;
1739}
1740
4c4b4cd2
PH
1741/* The number of index positions in the array-bounds type TYPE.
1742 Return 0 if TYPE is NULL. */
1743
14f9c5c9 1744static int
d2e4a39e 1745desc_arity (struct type *type)
14f9c5c9
AS
1746{
1747 type = desc_base_type (type);
1748
1749 if (type != NULL)
1750 return TYPE_NFIELDS (type) / 2;
1751 return 0;
1752}
1753
4c4b4cd2
PH
1754/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1755 an array descriptor type (representing an unconstrained array
1756 type). */
1757
76a01679
JB
1758static int
1759ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1760{
1761 if (type == NULL)
1762 return 0;
61ee279c 1763 type = ada_check_typedef (type);
4c4b4cd2 1764 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1765 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1766}
1767
52ce6436 1768/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1769 * to one. */
52ce6436 1770
2c0b251b 1771static int
52ce6436
PH
1772ada_is_array_type (struct type *type)
1773{
1774 while (type != NULL
1775 && (TYPE_CODE (type) == TYPE_CODE_PTR
1776 || TYPE_CODE (type) == TYPE_CODE_REF))
1777 type = TYPE_TARGET_TYPE (type);
1778 return ada_is_direct_array_type (type);
1779}
1780
4c4b4cd2 1781/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1782
14f9c5c9 1783int
4c4b4cd2 1784ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1785{
1786 if (type == NULL)
1787 return 0;
61ee279c 1788 type = ada_check_typedef (type);
14f9c5c9 1789 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1790 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1791 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1792 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1793}
1794
4c4b4cd2
PH
1795/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1796
14f9c5c9 1797int
4c4b4cd2 1798ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1799{
556bdfd4 1800 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1801
1802 if (type == NULL)
1803 return 0;
61ee279c 1804 type = ada_check_typedef (type);
556bdfd4
UW
1805 return (data_type != NULL
1806 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1807 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1808}
1809
1810/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1811 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1812 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1813 is still needed. */
1814
14f9c5c9 1815int
ebf56fd3 1816ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1817{
d2e4a39e 1818 return
14f9c5c9
AS
1819 type != NULL
1820 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1821 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1822 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1823 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1824}
1825
1826
4c4b4cd2 1827/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1828 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1829 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1830 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1831 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1832 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1833 a descriptor. */
d2e4a39e
AS
1834struct type *
1835ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1836{
ad82864c
JB
1837 if (ada_is_constrained_packed_array_type (value_type (arr)))
1838 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1839
df407dfe
AC
1840 if (!ada_is_array_descriptor_type (value_type (arr)))
1841 return value_type (arr);
d2e4a39e
AS
1842
1843 if (!bounds)
ad82864c
JB
1844 {
1845 struct type *array_type =
1846 ada_check_typedef (desc_data_target_type (value_type (arr)));
1847
1848 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1849 TYPE_FIELD_BITSIZE (array_type, 0) =
1850 decode_packed_array_bitsize (value_type (arr));
1851
1852 return array_type;
1853 }
14f9c5c9
AS
1854 else
1855 {
d2e4a39e 1856 struct type *elt_type;
14f9c5c9 1857 int arity;
d2e4a39e 1858 struct value *descriptor;
14f9c5c9 1859
df407dfe
AC
1860 elt_type = ada_array_element_type (value_type (arr), -1);
1861 arity = ada_array_arity (value_type (arr));
14f9c5c9 1862
d2e4a39e 1863 if (elt_type == NULL || arity == 0)
df407dfe 1864 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
1865
1866 descriptor = desc_bounds (arr);
d2e4a39e 1867 if (value_as_long (descriptor) == 0)
4c4b4cd2 1868 return NULL;
d2e4a39e 1869 while (arity > 0)
4c4b4cd2 1870 {
e9bb382b
UW
1871 struct type *range_type = alloc_type_copy (value_type (arr));
1872 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
1873 struct value *low = desc_one_bound (descriptor, arity, 0);
1874 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 1875
5b4ee69b 1876 arity -= 1;
df407dfe 1877 create_range_type (range_type, value_type (low),
529cad9c
PH
1878 longest_to_int (value_as_long (low)),
1879 longest_to_int (value_as_long (high)));
4c4b4cd2 1880 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
1881
1882 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
1883 {
1884 /* We need to store the element packed bitsize, as well as
1885 recompute the array size, because it was previously
1886 computed based on the unpacked element size. */
1887 LONGEST lo = value_as_long (low);
1888 LONGEST hi = value_as_long (high);
1889
1890 TYPE_FIELD_BITSIZE (elt_type, 0) =
1891 decode_packed_array_bitsize (value_type (arr));
1892 /* If the array has no element, then the size is already
1893 zero, and does not need to be recomputed. */
1894 if (lo < hi)
1895 {
1896 int array_bitsize =
1897 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1898
1899 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
1900 }
1901 }
4c4b4cd2 1902 }
14f9c5c9
AS
1903
1904 return lookup_pointer_type (elt_type);
1905 }
1906}
1907
1908/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
1909 Otherwise, returns either a standard GDB array with bounds set
1910 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1911 GDB array. Returns NULL if ARR is a null fat pointer. */
1912
d2e4a39e
AS
1913struct value *
1914ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 1915{
df407dfe 1916 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 1917 {
d2e4a39e 1918 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 1919
14f9c5c9 1920 if (arrType == NULL)
4c4b4cd2 1921 return NULL;
14f9c5c9
AS
1922 return value_cast (arrType, value_copy (desc_data (arr)));
1923 }
ad82864c
JB
1924 else if (ada_is_constrained_packed_array_type (value_type (arr)))
1925 return decode_constrained_packed_array (arr);
14f9c5c9
AS
1926 else
1927 return arr;
1928}
1929
1930/* If ARR does not represent an array, returns ARR unchanged.
1931 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
1932 be ARR itself if it already is in the proper form). */
1933
720d1a40 1934struct value *
d2e4a39e 1935ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 1936{
df407dfe 1937 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 1938 {
d2e4a39e 1939 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 1940
14f9c5c9 1941 if (arrVal == NULL)
323e0a4a 1942 error (_("Bounds unavailable for null array pointer."));
529cad9c 1943 check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
1944 return value_ind (arrVal);
1945 }
ad82864c
JB
1946 else if (ada_is_constrained_packed_array_type (value_type (arr)))
1947 return decode_constrained_packed_array (arr);
d2e4a39e 1948 else
14f9c5c9
AS
1949 return arr;
1950}
1951
1952/* If TYPE represents a GNAT array type, return it translated to an
1953 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
1954 packing). For other types, is the identity. */
1955
d2e4a39e
AS
1956struct type *
1957ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 1958{
ad82864c
JB
1959 if (ada_is_constrained_packed_array_type (type))
1960 return decode_constrained_packed_array_type (type);
17280b9f
UW
1961
1962 if (ada_is_array_descriptor_type (type))
556bdfd4 1963 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
1964
1965 return type;
14f9c5c9
AS
1966}
1967
4c4b4cd2
PH
1968/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1969
ad82864c
JB
1970static int
1971ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
1972{
1973 if (type == NULL)
1974 return 0;
4c4b4cd2 1975 type = desc_base_type (type);
61ee279c 1976 type = ada_check_typedef (type);
d2e4a39e 1977 return
14f9c5c9
AS
1978 ada_type_name (type) != NULL
1979 && strstr (ada_type_name (type), "___XP") != NULL;
1980}
1981
ad82864c
JB
1982/* Non-zero iff TYPE represents a standard GNAT constrained
1983 packed-array type. */
1984
1985int
1986ada_is_constrained_packed_array_type (struct type *type)
1987{
1988 return ada_is_packed_array_type (type)
1989 && !ada_is_array_descriptor_type (type);
1990}
1991
1992/* Non-zero iff TYPE represents an array descriptor for a
1993 unconstrained packed-array type. */
1994
1995static int
1996ada_is_unconstrained_packed_array_type (struct type *type)
1997{
1998 return ada_is_packed_array_type (type)
1999 && ada_is_array_descriptor_type (type);
2000}
2001
2002/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2003 return the size of its elements in bits. */
2004
2005static long
2006decode_packed_array_bitsize (struct type *type)
2007{
0d5cff50
DE
2008 const char *raw_name;
2009 const char *tail;
ad82864c
JB
2010 long bits;
2011
720d1a40
JB
2012 /* Access to arrays implemented as fat pointers are encoded as a typedef
2013 of the fat pointer type. We need the name of the fat pointer type
2014 to do the decoding, so strip the typedef layer. */
2015 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2016 type = ada_typedef_target_type (type);
2017
2018 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2019 if (!raw_name)
2020 raw_name = ada_type_name (desc_base_type (type));
2021
2022 if (!raw_name)
2023 return 0;
2024
2025 tail = strstr (raw_name, "___XP");
720d1a40 2026 gdb_assert (tail != NULL);
ad82864c
JB
2027
2028 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2029 {
2030 lim_warning
2031 (_("could not understand bit size information on packed array"));
2032 return 0;
2033 }
2034
2035 return bits;
2036}
2037
14f9c5c9
AS
2038/* Given that TYPE is a standard GDB array type with all bounds filled
2039 in, and that the element size of its ultimate scalar constituents
2040 (that is, either its elements, or, if it is an array of arrays, its
2041 elements' elements, etc.) is *ELT_BITS, return an identical type,
2042 but with the bit sizes of its elements (and those of any
2043 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2
PH
2044 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2045 in bits. */
2046
d2e4a39e 2047static struct type *
ad82864c 2048constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2049{
d2e4a39e
AS
2050 struct type *new_elt_type;
2051 struct type *new_type;
99b1c762
JB
2052 struct type *index_type_desc;
2053 struct type *index_type;
14f9c5c9
AS
2054 LONGEST low_bound, high_bound;
2055
61ee279c 2056 type = ada_check_typedef (type);
14f9c5c9
AS
2057 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2058 return type;
2059
99b1c762
JB
2060 index_type_desc = ada_find_parallel_type (type, "___XA");
2061 if (index_type_desc)
2062 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2063 NULL);
2064 else
2065 index_type = TYPE_INDEX_TYPE (type);
2066
e9bb382b 2067 new_type = alloc_type_copy (type);
ad82864c
JB
2068 new_elt_type =
2069 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2070 elt_bits);
99b1c762 2071 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2072 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2073 TYPE_NAME (new_type) = ada_type_name (type);
2074
99b1c762 2075 if (get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2076 low_bound = high_bound = 0;
2077 if (high_bound < low_bound)
2078 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2079 else
14f9c5c9
AS
2080 {
2081 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2082 TYPE_LENGTH (new_type) =
4c4b4cd2 2083 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2084 }
2085
876cecd0 2086 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2087 return new_type;
2088}
2089
ad82864c
JB
2090/* The array type encoded by TYPE, where
2091 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2092
d2e4a39e 2093static struct type *
ad82864c 2094decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2095{
0d5cff50 2096 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2097 char *name;
0d5cff50 2098 const char *tail;
d2e4a39e 2099 struct type *shadow_type;
14f9c5c9 2100 long bits;
14f9c5c9 2101
727e3d2e
JB
2102 if (!raw_name)
2103 raw_name = ada_type_name (desc_base_type (type));
2104
2105 if (!raw_name)
2106 return NULL;
2107
2108 name = (char *) alloca (strlen (raw_name) + 1);
2109 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2110 type = desc_base_type (type);
2111
14f9c5c9
AS
2112 memcpy (name, raw_name, tail - raw_name);
2113 name[tail - raw_name] = '\000';
2114
b4ba55a1
JB
2115 shadow_type = ada_find_parallel_type_with_name (type, name);
2116
2117 if (shadow_type == NULL)
14f9c5c9 2118 {
323e0a4a 2119 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2120 return NULL;
2121 }
cb249c71 2122 CHECK_TYPEDEF (shadow_type);
14f9c5c9
AS
2123
2124 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2125 {
0963b4bd
MS
2126 lim_warning (_("could not understand bounds "
2127 "information on packed array"));
14f9c5c9
AS
2128 return NULL;
2129 }
d2e4a39e 2130
ad82864c
JB
2131 bits = decode_packed_array_bitsize (type);
2132 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2133}
2134
ad82864c
JB
2135/* Given that ARR is a struct value *indicating a GNAT constrained packed
2136 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2137 standard GDB array type except that the BITSIZEs of the array
2138 target types are set to the number of bits in each element, and the
4c4b4cd2 2139 type length is set appropriately. */
14f9c5c9 2140
d2e4a39e 2141static struct value *
ad82864c 2142decode_constrained_packed_array (struct value *arr)
14f9c5c9 2143{
4c4b4cd2 2144 struct type *type;
14f9c5c9 2145
4c4b4cd2 2146 arr = ada_coerce_ref (arr);
284614f0
JB
2147
2148 /* If our value is a pointer, then dererence it. Make sure that
2149 this operation does not cause the target type to be fixed, as
2150 this would indirectly cause this array to be decoded. The rest
2151 of the routine assumes that the array hasn't been decoded yet,
2152 so we use the basic "value_ind" routine to perform the dereferencing,
2153 as opposed to using "ada_value_ind". */
828292f2 2154 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2155 arr = value_ind (arr);
4c4b4cd2 2156
ad82864c 2157 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2158 if (type == NULL)
2159 {
323e0a4a 2160 error (_("can't unpack array"));
14f9c5c9
AS
2161 return NULL;
2162 }
61ee279c 2163
50810684 2164 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2165 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2166 {
2167 /* This is a (right-justified) modular type representing a packed
2168 array with no wrapper. In order to interpret the value through
2169 the (left-justified) packed array type we just built, we must
2170 first left-justify it. */
2171 int bit_size, bit_pos;
2172 ULONGEST mod;
2173
df407dfe 2174 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2175 bit_size = 0;
2176 while (mod > 0)
2177 {
2178 bit_size += 1;
2179 mod >>= 1;
2180 }
df407dfe 2181 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2182 arr = ada_value_primitive_packed_val (arr, NULL,
2183 bit_pos / HOST_CHAR_BIT,
2184 bit_pos % HOST_CHAR_BIT,
2185 bit_size,
2186 type);
2187 }
2188
4c4b4cd2 2189 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2190}
2191
2192
2193/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2194 given in IND. ARR must be a simple array. */
14f9c5c9 2195
d2e4a39e
AS
2196static struct value *
2197value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2198{
2199 int i;
2200 int bits, elt_off, bit_off;
2201 long elt_total_bit_offset;
d2e4a39e
AS
2202 struct type *elt_type;
2203 struct value *v;
14f9c5c9
AS
2204
2205 bits = 0;
2206 elt_total_bit_offset = 0;
df407dfe 2207 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2208 for (i = 0; i < arity; i += 1)
14f9c5c9 2209 {
d2e4a39e 2210 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2211 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2212 error
0963b4bd
MS
2213 (_("attempt to do packed indexing of "
2214 "something other than a packed array"));
14f9c5c9 2215 else
4c4b4cd2
PH
2216 {
2217 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2218 LONGEST lowerbound, upperbound;
2219 LONGEST idx;
2220
2221 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2222 {
323e0a4a 2223 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2224 lowerbound = upperbound = 0;
2225 }
2226
3cb382c9 2227 idx = pos_atr (ind[i]);
4c4b4cd2 2228 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2229 lim_warning (_("packed array index %ld out of bounds"),
2230 (long) idx);
4c4b4cd2
PH
2231 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2232 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2233 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2234 }
14f9c5c9
AS
2235 }
2236 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2237 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2238
2239 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2240 bits, elt_type);
14f9c5c9
AS
2241 return v;
2242}
2243
4c4b4cd2 2244/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2245
2246static int
d2e4a39e 2247has_negatives (struct type *type)
14f9c5c9 2248{
d2e4a39e
AS
2249 switch (TYPE_CODE (type))
2250 {
2251 default:
2252 return 0;
2253 case TYPE_CODE_INT:
2254 return !TYPE_UNSIGNED (type);
2255 case TYPE_CODE_RANGE:
2256 return TYPE_LOW_BOUND (type) < 0;
2257 }
14f9c5c9 2258}
d2e4a39e 2259
14f9c5c9
AS
2260
2261/* Create a new value of type TYPE from the contents of OBJ starting
2262 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2263 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
0963b4bd 2264 assigning through the result will set the field fetched from.
4c4b4cd2
PH
2265 VALADDR is ignored unless OBJ is NULL, in which case,
2266 VALADDR+OFFSET must address the start of storage containing the
2267 packed value. The value returned in this case is never an lval.
2268 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
14f9c5c9 2269
d2e4a39e 2270struct value *
fc1a4b47 2271ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
a2bd3dcd 2272 long offset, int bit_offset, int bit_size,
4c4b4cd2 2273 struct type *type)
14f9c5c9 2274{
d2e4a39e 2275 struct value *v;
4c4b4cd2
PH
2276 int src, /* Index into the source area */
2277 targ, /* Index into the target area */
2278 srcBitsLeft, /* Number of source bits left to move */
2279 nsrc, ntarg, /* Number of source and target bytes */
2280 unusedLS, /* Number of bits in next significant
2281 byte of source that are unused */
2282 accumSize; /* Number of meaningful bits in accum */
2283 unsigned char *bytes; /* First byte containing data to unpack */
d2e4a39e 2284 unsigned char *unpacked;
4c4b4cd2 2285 unsigned long accum; /* Staging area for bits being transferred */
14f9c5c9
AS
2286 unsigned char sign;
2287 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
4c4b4cd2
PH
2288 /* Transmit bytes from least to most significant; delta is the direction
2289 the indices move. */
50810684 2290 int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1;
14f9c5c9 2291
61ee279c 2292 type = ada_check_typedef (type);
14f9c5c9
AS
2293
2294 if (obj == NULL)
2295 {
2296 v = allocate_value (type);
d2e4a39e 2297 bytes = (unsigned char *) (valaddr + offset);
14f9c5c9 2298 }
9214ee5f 2299 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
14f9c5c9 2300 {
53ba8333 2301 v = value_at (type, value_address (obj));
d2e4a39e 2302 bytes = (unsigned char *) alloca (len);
53ba8333 2303 read_memory (value_address (v) + offset, bytes, len);
14f9c5c9 2304 }
d2e4a39e 2305 else
14f9c5c9
AS
2306 {
2307 v = allocate_value (type);
0fd88904 2308 bytes = (unsigned char *) value_contents (obj) + offset;
14f9c5c9 2309 }
d2e4a39e
AS
2310
2311 if (obj != NULL)
14f9c5c9 2312 {
53ba8333 2313 long new_offset = offset;
5b4ee69b 2314
74bcbdf3 2315 set_value_component_location (v, obj);
9bbda503
AC
2316 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2317 set_value_bitsize (v, bit_size);
df407dfe 2318 if (value_bitpos (v) >= HOST_CHAR_BIT)
4c4b4cd2 2319 {
53ba8333 2320 ++new_offset;
9bbda503 2321 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
4c4b4cd2 2322 }
53ba8333
JB
2323 set_value_offset (v, new_offset);
2324
2325 /* Also set the parent value. This is needed when trying to
2326 assign a new value (in inferior memory). */
2327 set_value_parent (v, obj);
14f9c5c9
AS
2328 }
2329 else
9bbda503 2330 set_value_bitsize (v, bit_size);
0fd88904 2331 unpacked = (unsigned char *) value_contents (v);
14f9c5c9
AS
2332
2333 srcBitsLeft = bit_size;
2334 nsrc = len;
2335 ntarg = TYPE_LENGTH (type);
2336 sign = 0;
2337 if (bit_size == 0)
2338 {
2339 memset (unpacked, 0, TYPE_LENGTH (type));
2340 return v;
2341 }
50810684 2342 else if (gdbarch_bits_big_endian (get_type_arch (type)))
14f9c5c9 2343 {
d2e4a39e 2344 src = len - 1;
1265e4aa
JB
2345 if (has_negatives (type)
2346 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2347 sign = ~0;
d2e4a39e
AS
2348
2349 unusedLS =
4c4b4cd2
PH
2350 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2351 % HOST_CHAR_BIT;
14f9c5c9
AS
2352
2353 switch (TYPE_CODE (type))
4c4b4cd2
PH
2354 {
2355 case TYPE_CODE_ARRAY:
2356 case TYPE_CODE_UNION:
2357 case TYPE_CODE_STRUCT:
2358 /* Non-scalar values must be aligned at a byte boundary... */
2359 accumSize =
2360 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2361 /* ... And are placed at the beginning (most-significant) bytes
2362 of the target. */
529cad9c 2363 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
0056e4d5 2364 ntarg = targ + 1;
4c4b4cd2
PH
2365 break;
2366 default:
2367 accumSize = 0;
2368 targ = TYPE_LENGTH (type) - 1;
2369 break;
2370 }
14f9c5c9 2371 }
d2e4a39e 2372 else
14f9c5c9
AS
2373 {
2374 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2375
2376 src = targ = 0;
2377 unusedLS = bit_offset;
2378 accumSize = 0;
2379
d2e4a39e 2380 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2381 sign = ~0;
14f9c5c9 2382 }
d2e4a39e 2383
14f9c5c9
AS
2384 accum = 0;
2385 while (nsrc > 0)
2386 {
2387 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2388 part of the value. */
d2e4a39e 2389 unsigned int unusedMSMask =
4c4b4cd2
PH
2390 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2391 1;
2392 /* Sign-extend bits for this byte. */
14f9c5c9 2393 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2394
d2e4a39e 2395 accum |=
4c4b4cd2 2396 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2397 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2398 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2
PH
2399 {
2400 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2401 accumSize -= HOST_CHAR_BIT;
2402 accum >>= HOST_CHAR_BIT;
2403 ntarg -= 1;
2404 targ += delta;
2405 }
14f9c5c9
AS
2406 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2407 unusedLS = 0;
2408 nsrc -= 1;
2409 src += delta;
2410 }
2411 while (ntarg > 0)
2412 {
2413 accum |= sign << accumSize;
2414 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2415 accumSize -= HOST_CHAR_BIT;
2416 accum >>= HOST_CHAR_BIT;
2417 ntarg -= 1;
2418 targ += delta;
2419 }
2420
2421 return v;
2422}
d2e4a39e 2423
14f9c5c9
AS
2424/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2425 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2426 not overlap. */
14f9c5c9 2427static void
fc1a4b47 2428move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2429 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2430{
2431 unsigned int accum, mask;
2432 int accum_bits, chunk_size;
2433
2434 target += targ_offset / HOST_CHAR_BIT;
2435 targ_offset %= HOST_CHAR_BIT;
2436 source += src_offset / HOST_CHAR_BIT;
2437 src_offset %= HOST_CHAR_BIT;
50810684 2438 if (bits_big_endian_p)
14f9c5c9
AS
2439 {
2440 accum = (unsigned char) *source;
2441 source += 1;
2442 accum_bits = HOST_CHAR_BIT - src_offset;
2443
d2e4a39e 2444 while (n > 0)
4c4b4cd2
PH
2445 {
2446 int unused_right;
5b4ee69b 2447
4c4b4cd2
PH
2448 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2449 accum_bits += HOST_CHAR_BIT;
2450 source += 1;
2451 chunk_size = HOST_CHAR_BIT - targ_offset;
2452 if (chunk_size > n)
2453 chunk_size = n;
2454 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2455 mask = ((1 << chunk_size) - 1) << unused_right;
2456 *target =
2457 (*target & ~mask)
2458 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2459 n -= chunk_size;
2460 accum_bits -= chunk_size;
2461 target += 1;
2462 targ_offset = 0;
2463 }
14f9c5c9
AS
2464 }
2465 else
2466 {
2467 accum = (unsigned char) *source >> src_offset;
2468 source += 1;
2469 accum_bits = HOST_CHAR_BIT - src_offset;
2470
d2e4a39e 2471 while (n > 0)
4c4b4cd2
PH
2472 {
2473 accum = accum + ((unsigned char) *source << accum_bits);
2474 accum_bits += HOST_CHAR_BIT;
2475 source += 1;
2476 chunk_size = HOST_CHAR_BIT - targ_offset;
2477 if (chunk_size > n)
2478 chunk_size = n;
2479 mask = ((1 << chunk_size) - 1) << targ_offset;
2480 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2481 n -= chunk_size;
2482 accum_bits -= chunk_size;
2483 accum >>= chunk_size;
2484 target += 1;
2485 targ_offset = 0;
2486 }
14f9c5c9
AS
2487 }
2488}
2489
14f9c5c9
AS
2490/* Store the contents of FROMVAL into the location of TOVAL.
2491 Return a new value with the location of TOVAL and contents of
2492 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2493 floating-point or non-scalar types. */
14f9c5c9 2494
d2e4a39e
AS
2495static struct value *
2496ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2497{
df407dfe
AC
2498 struct type *type = value_type (toval);
2499 int bits = value_bitsize (toval);
14f9c5c9 2500
52ce6436
PH
2501 toval = ada_coerce_ref (toval);
2502 fromval = ada_coerce_ref (fromval);
2503
2504 if (ada_is_direct_array_type (value_type (toval)))
2505 toval = ada_coerce_to_simple_array (toval);
2506 if (ada_is_direct_array_type (value_type (fromval)))
2507 fromval = ada_coerce_to_simple_array (fromval);
2508
88e3b34b 2509 if (!deprecated_value_modifiable (toval))
323e0a4a 2510 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2511
d2e4a39e 2512 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2513 && bits > 0
d2e4a39e 2514 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2515 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2516 {
df407dfe
AC
2517 int len = (value_bitpos (toval)
2518 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2519 int from_size;
948f8e3d 2520 gdb_byte *buffer = alloca (len);
d2e4a39e 2521 struct value *val;
42ae5230 2522 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2523
2524 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2525 fromval = value_cast (type, fromval);
14f9c5c9 2526
52ce6436 2527 read_memory (to_addr, buffer, len);
aced2898
PH
2528 from_size = value_bitsize (fromval);
2529 if (from_size == 0)
2530 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2531 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2532 move_bits (buffer, value_bitpos (toval),
50810684 2533 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2534 else
50810684
UW
2535 move_bits (buffer, value_bitpos (toval),
2536 value_contents (fromval), 0, bits, 0);
972daa01 2537 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2538
14f9c5c9 2539 val = value_copy (toval);
0fd88904 2540 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2541 TYPE_LENGTH (type));
04624583 2542 deprecated_set_value_type (val, type);
d2e4a39e 2543
14f9c5c9
AS
2544 return val;
2545 }
2546
2547 return value_assign (toval, fromval);
2548}
2549
2550
52ce6436
PH
2551/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2552 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2553 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2554 * COMPONENT, and not the inferior's memory. The current contents
2555 * of COMPONENT are ignored. */
2556static void
2557value_assign_to_component (struct value *container, struct value *component,
2558 struct value *val)
2559{
2560 LONGEST offset_in_container =
42ae5230 2561 (LONGEST) (value_address (component) - value_address (container));
52ce6436
PH
2562 int bit_offset_in_container =
2563 value_bitpos (component) - value_bitpos (container);
2564 int bits;
2565
2566 val = value_cast (value_type (component), val);
2567
2568 if (value_bitsize (component) == 0)
2569 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2570 else
2571 bits = value_bitsize (component);
2572
50810684 2573 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
52ce6436
PH
2574 move_bits (value_contents_writeable (container) + offset_in_container,
2575 value_bitpos (container) + bit_offset_in_container,
2576 value_contents (val),
2577 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
50810684 2578 bits, 1);
52ce6436
PH
2579 else
2580 move_bits (value_contents_writeable (container) + offset_in_container,
2581 value_bitpos (container) + bit_offset_in_container,
50810684 2582 value_contents (val), 0, bits, 0);
52ce6436
PH
2583}
2584
4c4b4cd2
PH
2585/* The value of the element of array ARR at the ARITY indices given in IND.
2586 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2587 thereto. */
2588
d2e4a39e
AS
2589struct value *
2590ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2591{
2592 int k;
d2e4a39e
AS
2593 struct value *elt;
2594 struct type *elt_type;
14f9c5c9
AS
2595
2596 elt = ada_coerce_to_simple_array (arr);
2597
df407dfe 2598 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2599 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2600 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2601 return value_subscript_packed (elt, arity, ind);
2602
2603 for (k = 0; k < arity; k += 1)
2604 {
2605 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2606 error (_("too many subscripts (%d expected)"), k);
2497b498 2607 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2608 }
2609 return elt;
2610}
2611
2612/* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2613 value of the element of *ARR at the ARITY indices given in
4c4b4cd2 2614 IND. Does not read the entire array into memory. */
14f9c5c9 2615
2c0b251b 2616static struct value *
d2e4a39e 2617ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
4c4b4cd2 2618 struct value **ind)
14f9c5c9
AS
2619{
2620 int k;
2621
2622 for (k = 0; k < arity; k += 1)
2623 {
2624 LONGEST lwb, upb;
14f9c5c9
AS
2625
2626 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2627 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2628 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2629 value_copy (arr));
14f9c5c9 2630 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2497b498 2631 arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
14f9c5c9
AS
2632 type = TYPE_TARGET_TYPE (type);
2633 }
2634
2635 return value_ind (arr);
2636}
2637
0b5d8877 2638/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
f5938064
JG
2639 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2640 elements starting at index LOW. The lower bound of this array is LOW, as
0963b4bd 2641 per Ada rules. */
0b5d8877 2642static struct value *
f5938064
JG
2643ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2644 int low, int high)
0b5d8877 2645{
b0dd7688 2646 struct type *type0 = ada_check_typedef (type);
6c038f32 2647 CORE_ADDR base = value_as_address (array_ptr)
b0dd7688
JB
2648 + ((low - ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0)))
2649 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
6c038f32 2650 struct type *index_type =
b0dd7688 2651 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)),
0b5d8877 2652 low, high);
6c038f32 2653 struct type *slice_type =
b0dd7688 2654 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
5b4ee69b 2655
f5938064 2656 return value_at_lazy (slice_type, base);
0b5d8877
PH
2657}
2658
2659
2660static struct value *
2661ada_value_slice (struct value *array, int low, int high)
2662{
b0dd7688 2663 struct type *type = ada_check_typedef (value_type (array));
6c038f32 2664 struct type *index_type =
0b5d8877 2665 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
6c038f32 2666 struct type *slice_type =
0b5d8877 2667 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
5b4ee69b 2668
6c038f32 2669 return value_cast (slice_type, value_slice (array, low, high - low + 1));
0b5d8877
PH
2670}
2671
14f9c5c9
AS
2672/* If type is a record type in the form of a standard GNAT array
2673 descriptor, returns the number of dimensions for type. If arr is a
2674 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2675 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2676
2677int
d2e4a39e 2678ada_array_arity (struct type *type)
14f9c5c9
AS
2679{
2680 int arity;
2681
2682 if (type == NULL)
2683 return 0;
2684
2685 type = desc_base_type (type);
2686
2687 arity = 0;
d2e4a39e 2688 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2689 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2690 else
2691 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2692 {
4c4b4cd2 2693 arity += 1;
61ee279c 2694 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2695 }
d2e4a39e 2696
14f9c5c9
AS
2697 return arity;
2698}
2699
2700/* If TYPE is a record type in the form of a standard GNAT array
2701 descriptor or a simple array type, returns the element type for
2702 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2703 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2704
d2e4a39e
AS
2705struct type *
2706ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2707{
2708 type = desc_base_type (type);
2709
d2e4a39e 2710 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2711 {
2712 int k;
d2e4a39e 2713 struct type *p_array_type;
14f9c5c9 2714
556bdfd4 2715 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
2716
2717 k = ada_array_arity (type);
2718 if (k == 0)
4c4b4cd2 2719 return NULL;
d2e4a39e 2720
4c4b4cd2 2721 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2722 if (nindices >= 0 && k > nindices)
4c4b4cd2 2723 k = nindices;
d2e4a39e 2724 while (k > 0 && p_array_type != NULL)
4c4b4cd2 2725 {
61ee279c 2726 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
2727 k -= 1;
2728 }
14f9c5c9
AS
2729 return p_array_type;
2730 }
2731 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2732 {
2733 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
2734 {
2735 type = TYPE_TARGET_TYPE (type);
2736 nindices -= 1;
2737 }
14f9c5c9
AS
2738 return type;
2739 }
2740
2741 return NULL;
2742}
2743
4c4b4cd2 2744/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
2745 Does not examine memory. Throws an error if N is invalid or TYPE
2746 is not an array type. NAME is the name of the Ada attribute being
2747 evaluated ('range, 'first, 'last, or 'length); it is used in building
2748 the error message. */
14f9c5c9 2749
1eea4ebd
UW
2750static struct type *
2751ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 2752{
4c4b4cd2
PH
2753 struct type *result_type;
2754
14f9c5c9
AS
2755 type = desc_base_type (type);
2756
1eea4ebd
UW
2757 if (n < 0 || n > ada_array_arity (type))
2758 error (_("invalid dimension number to '%s"), name);
14f9c5c9 2759
4c4b4cd2 2760 if (ada_is_simple_array_type (type))
14f9c5c9
AS
2761 {
2762 int i;
2763
2764 for (i = 1; i < n; i += 1)
4c4b4cd2 2765 type = TYPE_TARGET_TYPE (type);
262452ec 2766 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
2767 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2768 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 2769 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
2770 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2771 result_type = NULL;
14f9c5c9 2772 }
d2e4a39e 2773 else
1eea4ebd
UW
2774 {
2775 result_type = desc_index_type (desc_bounds_type (type), n);
2776 if (result_type == NULL)
2777 error (_("attempt to take bound of something that is not an array"));
2778 }
2779
2780 return result_type;
14f9c5c9
AS
2781}
2782
2783/* Given that arr is an array type, returns the lower bound of the
2784 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 2785 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
2786 array-descriptor type. It works for other arrays with bounds supplied
2787 by run-time quantities other than discriminants. */
14f9c5c9 2788
abb68b3e 2789static LONGEST
1eea4ebd 2790ada_array_bound_from_type (struct type * arr_type, int n, int which)
14f9c5c9 2791{
1ce677a4 2792 struct type *type, *elt_type, *index_type_desc, *index_type;
1ce677a4 2793 int i;
262452ec
JK
2794
2795 gdb_assert (which == 0 || which == 1);
14f9c5c9 2796
ad82864c
JB
2797 if (ada_is_constrained_packed_array_type (arr_type))
2798 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 2799
4c4b4cd2 2800 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 2801 return (LONGEST) - which;
14f9c5c9
AS
2802
2803 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2804 type = TYPE_TARGET_TYPE (arr_type);
2805 else
2806 type = arr_type;
2807
1ce677a4
UW
2808 elt_type = type;
2809 for (i = n; i > 1; i--)
2810 elt_type = TYPE_TARGET_TYPE (type);
2811
14f9c5c9 2812 index_type_desc = ada_find_parallel_type (type, "___XA");
28c85d6c 2813 ada_fixup_array_indexes_type (index_type_desc);
262452ec 2814 if (index_type_desc != NULL)
28c85d6c
JB
2815 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
2816 NULL);
262452ec 2817 else
1ce677a4 2818 index_type = TYPE_INDEX_TYPE (elt_type);
262452ec 2819
43bbcdc2
PH
2820 return
2821 (LONGEST) (which == 0
2822 ? ada_discrete_type_low_bound (index_type)
2823 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
2824}
2825
2826/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
2827 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2828 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 2829 supplied by run-time quantities other than discriminants. */
14f9c5c9 2830
1eea4ebd 2831static LONGEST
4dc81987 2832ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 2833{
df407dfe 2834 struct type *arr_type = value_type (arr);
14f9c5c9 2835
ad82864c
JB
2836 if (ada_is_constrained_packed_array_type (arr_type))
2837 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 2838 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 2839 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 2840 else
1eea4ebd 2841 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
2842}
2843
2844/* Given that arr is an array value, returns the length of the
2845 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
2846 supplied by run-time quantities other than discriminants.
2847 Does not work for arrays indexed by enumeration types with representation
2848 clauses at the moment. */
14f9c5c9 2849
1eea4ebd 2850static LONGEST
d2e4a39e 2851ada_array_length (struct value *arr, int n)
14f9c5c9 2852{
df407dfe 2853 struct type *arr_type = ada_check_typedef (value_type (arr));
14f9c5c9 2854
ad82864c
JB
2855 if (ada_is_constrained_packed_array_type (arr_type))
2856 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 2857
4c4b4cd2 2858 if (ada_is_simple_array_type (arr_type))
1eea4ebd
UW
2859 return (ada_array_bound_from_type (arr_type, n, 1)
2860 - ada_array_bound_from_type (arr_type, n, 0) + 1);
14f9c5c9 2861 else
1eea4ebd
UW
2862 return (value_as_long (desc_one_bound (desc_bounds (arr), n, 1))
2863 - value_as_long (desc_one_bound (desc_bounds (arr), n, 0)) + 1);
4c4b4cd2
PH
2864}
2865
2866/* An empty array whose type is that of ARR_TYPE (an array type),
2867 with bounds LOW to LOW-1. */
2868
2869static struct value *
2870empty_array (struct type *arr_type, int low)
2871{
b0dd7688 2872 struct type *arr_type0 = ada_check_typedef (arr_type);
6c038f32 2873 struct type *index_type =
b0dd7688 2874 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)),
0b5d8877 2875 low, low - 1);
b0dd7688 2876 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 2877
0b5d8877 2878 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 2879}
14f9c5c9 2880\f
d2e4a39e 2881
4c4b4cd2 2882 /* Name resolution */
14f9c5c9 2883
4c4b4cd2
PH
2884/* The "decoded" name for the user-definable Ada operator corresponding
2885 to OP. */
14f9c5c9 2886
d2e4a39e 2887static const char *
4c4b4cd2 2888ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
2889{
2890 int i;
2891
4c4b4cd2 2892 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
2893 {
2894 if (ada_opname_table[i].op == op)
4c4b4cd2 2895 return ada_opname_table[i].decoded;
14f9c5c9 2896 }
323e0a4a 2897 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
2898}
2899
2900
4c4b4cd2
PH
2901/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2902 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2903 undefined namespace) and converts operators that are
2904 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
2905 non-null, it provides a preferred result type [at the moment, only
2906 type void has any effect---causing procedures to be preferred over
2907 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 2908 return type is preferred. May change (expand) *EXP. */
14f9c5c9 2909
4c4b4cd2
PH
2910static void
2911resolve (struct expression **expp, int void_context_p)
14f9c5c9 2912{
30b15541
UW
2913 struct type *context_type = NULL;
2914 int pc = 0;
2915
2916 if (void_context_p)
2917 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
2918
2919 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
2920}
2921
4c4b4cd2
PH
2922/* Resolve the operator of the subexpression beginning at
2923 position *POS of *EXPP. "Resolving" consists of replacing
2924 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2925 with their resolutions, replacing built-in operators with
2926 function calls to user-defined operators, where appropriate, and,
2927 when DEPROCEDURE_P is non-zero, converting function-valued variables
2928 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2929 are as in ada_resolve, above. */
14f9c5c9 2930
d2e4a39e 2931static struct value *
4c4b4cd2 2932resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
76a01679 2933 struct type *context_type)
14f9c5c9
AS
2934{
2935 int pc = *pos;
2936 int i;
4c4b4cd2 2937 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 2938 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
2939 struct value **argvec; /* Vector of operand types (alloca'ed). */
2940 int nargs; /* Number of operands. */
52ce6436 2941 int oplen;
14f9c5c9
AS
2942
2943 argvec = NULL;
2944 nargs = 0;
2945 exp = *expp;
2946
52ce6436
PH
2947 /* Pass one: resolve operands, saving their types and updating *pos,
2948 if needed. */
14f9c5c9
AS
2949 switch (op)
2950 {
4c4b4cd2
PH
2951 case OP_FUNCALL:
2952 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
2953 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2954 *pos += 7;
4c4b4cd2
PH
2955 else
2956 {
2957 *pos += 3;
2958 resolve_subexp (expp, pos, 0, NULL);
2959 }
2960 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
2961 break;
2962
14f9c5c9 2963 case UNOP_ADDR:
4c4b4cd2
PH
2964 *pos += 1;
2965 resolve_subexp (expp, pos, 0, NULL);
2966 break;
2967
52ce6436
PH
2968 case UNOP_QUAL:
2969 *pos += 3;
17466c1a 2970 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
2971 break;
2972
52ce6436 2973 case OP_ATR_MODULUS:
4c4b4cd2
PH
2974 case OP_ATR_SIZE:
2975 case OP_ATR_TAG:
4c4b4cd2
PH
2976 case OP_ATR_FIRST:
2977 case OP_ATR_LAST:
2978 case OP_ATR_LENGTH:
2979 case OP_ATR_POS:
2980 case OP_ATR_VAL:
4c4b4cd2
PH
2981 case OP_ATR_MIN:
2982 case OP_ATR_MAX:
52ce6436
PH
2983 case TERNOP_IN_RANGE:
2984 case BINOP_IN_BOUNDS:
2985 case UNOP_IN_RANGE:
2986 case OP_AGGREGATE:
2987 case OP_OTHERS:
2988 case OP_CHOICES:
2989 case OP_POSITIONAL:
2990 case OP_DISCRETE_RANGE:
2991 case OP_NAME:
2992 ada_forward_operator_length (exp, pc, &oplen, &nargs);
2993 *pos += oplen;
14f9c5c9
AS
2994 break;
2995
2996 case BINOP_ASSIGN:
2997 {
4c4b4cd2
PH
2998 struct value *arg1;
2999
3000 *pos += 1;
3001 arg1 = resolve_subexp (expp, pos, 0, NULL);
3002 if (arg1 == NULL)
3003 resolve_subexp (expp, pos, 1, NULL);
3004 else
df407dfe 3005 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 3006 break;
14f9c5c9
AS
3007 }
3008
4c4b4cd2 3009 case UNOP_CAST:
4c4b4cd2
PH
3010 *pos += 3;
3011 nargs = 1;
3012 break;
14f9c5c9 3013
4c4b4cd2
PH
3014 case BINOP_ADD:
3015 case BINOP_SUB:
3016 case BINOP_MUL:
3017 case BINOP_DIV:
3018 case BINOP_REM:
3019 case BINOP_MOD:
3020 case BINOP_EXP:
3021 case BINOP_CONCAT:
3022 case BINOP_LOGICAL_AND:
3023 case BINOP_LOGICAL_OR:
3024 case BINOP_BITWISE_AND:
3025 case BINOP_BITWISE_IOR:
3026 case BINOP_BITWISE_XOR:
14f9c5c9 3027
4c4b4cd2
PH
3028 case BINOP_EQUAL:
3029 case BINOP_NOTEQUAL:
3030 case BINOP_LESS:
3031 case BINOP_GTR:
3032 case BINOP_LEQ:
3033 case BINOP_GEQ:
14f9c5c9 3034
4c4b4cd2
PH
3035 case BINOP_REPEAT:
3036 case BINOP_SUBSCRIPT:
3037 case BINOP_COMMA:
40c8aaa9
JB
3038 *pos += 1;
3039 nargs = 2;
3040 break;
14f9c5c9 3041
4c4b4cd2
PH
3042 case UNOP_NEG:
3043 case UNOP_PLUS:
3044 case UNOP_LOGICAL_NOT:
3045 case UNOP_ABS:
3046 case UNOP_IND:
3047 *pos += 1;
3048 nargs = 1;
3049 break;
14f9c5c9 3050
4c4b4cd2
PH
3051 case OP_LONG:
3052 case OP_DOUBLE:
3053 case OP_VAR_VALUE:
3054 *pos += 4;
3055 break;
14f9c5c9 3056
4c4b4cd2
PH
3057 case OP_TYPE:
3058 case OP_BOOL:
3059 case OP_LAST:
4c4b4cd2
PH
3060 case OP_INTERNALVAR:
3061 *pos += 3;
3062 break;
14f9c5c9 3063
4c4b4cd2
PH
3064 case UNOP_MEMVAL:
3065 *pos += 3;
3066 nargs = 1;
3067 break;
3068
67f3407f
DJ
3069 case OP_REGISTER:
3070 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3071 break;
3072
4c4b4cd2
PH
3073 case STRUCTOP_STRUCT:
3074 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3075 nargs = 1;
3076 break;
3077
4c4b4cd2 3078 case TERNOP_SLICE:
4c4b4cd2
PH
3079 *pos += 1;
3080 nargs = 3;
3081 break;
3082
52ce6436 3083 case OP_STRING:
14f9c5c9 3084 break;
4c4b4cd2
PH
3085
3086 default:
323e0a4a 3087 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3088 }
3089
76a01679 3090 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
4c4b4cd2
PH
3091 for (i = 0; i < nargs; i += 1)
3092 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3093 argvec[i] = NULL;
3094 exp = *expp;
3095
3096 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3097 switch (op)
3098 {
3099 default:
3100 break;
3101
14f9c5c9 3102 case OP_VAR_VALUE:
4c4b4cd2 3103 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
3104 {
3105 struct ada_symbol_info *candidates;
3106 int n_candidates;
3107
3108 n_candidates =
3109 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3110 (exp->elts[pc + 2].symbol),
3111 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3112 &candidates);
76a01679
JB
3113
3114 if (n_candidates > 1)
3115 {
3116 /* Types tend to get re-introduced locally, so if there
3117 are any local symbols that are not types, first filter
3118 out all types. */
3119 int j;
3120 for (j = 0; j < n_candidates; j += 1)
3121 switch (SYMBOL_CLASS (candidates[j].sym))
3122 {
3123 case LOC_REGISTER:
3124 case LOC_ARG:
3125 case LOC_REF_ARG:
76a01679
JB
3126 case LOC_REGPARM_ADDR:
3127 case LOC_LOCAL:
76a01679 3128 case LOC_COMPUTED:
76a01679
JB
3129 goto FoundNonType;
3130 default:
3131 break;
3132 }
3133 FoundNonType:
3134 if (j < n_candidates)
3135 {
3136 j = 0;
3137 while (j < n_candidates)
3138 {
3139 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
3140 {
3141 candidates[j] = candidates[n_candidates - 1];
3142 n_candidates -= 1;
3143 }
3144 else
3145 j += 1;
3146 }
3147 }
3148 }
3149
3150 if (n_candidates == 0)
323e0a4a 3151 error (_("No definition found for %s"),
76a01679
JB
3152 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3153 else if (n_candidates == 1)
3154 i = 0;
3155 else if (deprocedure_p
3156 && !is_nonfunction (candidates, n_candidates))
3157 {
06d5cf63
JB
3158 i = ada_resolve_function
3159 (candidates, n_candidates, NULL, 0,
3160 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3161 context_type);
76a01679 3162 if (i < 0)
323e0a4a 3163 error (_("Could not find a match for %s"),
76a01679
JB
3164 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3165 }
3166 else
3167 {
323e0a4a 3168 printf_filtered (_("Multiple matches for %s\n"),
76a01679
JB
3169 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3170 user_select_syms (candidates, n_candidates, 1);
3171 i = 0;
3172 }
3173
3174 exp->elts[pc + 1].block = candidates[i].block;
3175 exp->elts[pc + 2].symbol = candidates[i].sym;
1265e4aa
JB
3176 if (innermost_block == NULL
3177 || contained_in (candidates[i].block, innermost_block))
76a01679
JB
3178 innermost_block = candidates[i].block;
3179 }
3180
3181 if (deprocedure_p
3182 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3183 == TYPE_CODE_FUNC))
3184 {
3185 replace_operator_with_call (expp, pc, 0, 0,
3186 exp->elts[pc + 2].symbol,
3187 exp->elts[pc + 1].block);
3188 exp = *expp;
3189 }
14f9c5c9
AS
3190 break;
3191
3192 case OP_FUNCALL:
3193 {
4c4b4cd2 3194 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3195 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2
PH
3196 {
3197 struct ada_symbol_info *candidates;
3198 int n_candidates;
3199
3200 n_candidates =
76a01679
JB
3201 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3202 (exp->elts[pc + 5].symbol),
3203 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3204 &candidates);
4c4b4cd2
PH
3205 if (n_candidates == 1)
3206 i = 0;
3207 else
3208 {
06d5cf63
JB
3209 i = ada_resolve_function
3210 (candidates, n_candidates,
3211 argvec, nargs,
3212 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3213 context_type);
4c4b4cd2 3214 if (i < 0)
323e0a4a 3215 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3216 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3217 }
3218
3219 exp->elts[pc + 4].block = candidates[i].block;
3220 exp->elts[pc + 5].symbol = candidates[i].sym;
1265e4aa
JB
3221 if (innermost_block == NULL
3222 || contained_in (candidates[i].block, innermost_block))
4c4b4cd2
PH
3223 innermost_block = candidates[i].block;
3224 }
14f9c5c9
AS
3225 }
3226 break;
3227 case BINOP_ADD:
3228 case BINOP_SUB:
3229 case BINOP_MUL:
3230 case BINOP_DIV:
3231 case BINOP_REM:
3232 case BINOP_MOD:
3233 case BINOP_CONCAT:
3234 case BINOP_BITWISE_AND:
3235 case BINOP_BITWISE_IOR:
3236 case BINOP_BITWISE_XOR:
3237 case BINOP_EQUAL:
3238 case BINOP_NOTEQUAL:
3239 case BINOP_LESS:
3240 case BINOP_GTR:
3241 case BINOP_LEQ:
3242 case BINOP_GEQ:
3243 case BINOP_EXP:
3244 case UNOP_NEG:
3245 case UNOP_PLUS:
3246 case UNOP_LOGICAL_NOT:
3247 case UNOP_ABS:
3248 if (possible_user_operator_p (op, argvec))
4c4b4cd2
PH
3249 {
3250 struct ada_symbol_info *candidates;
3251 int n_candidates;
3252
3253 n_candidates =
3254 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3255 (struct block *) NULL, VAR_DOMAIN,
4eeaa230 3256 &candidates);
4c4b4cd2 3257 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
76a01679 3258 ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3259 if (i < 0)
3260 break;
3261
76a01679
JB
3262 replace_operator_with_call (expp, pc, nargs, 1,
3263 candidates[i].sym, candidates[i].block);
4c4b4cd2
PH
3264 exp = *expp;
3265 }
14f9c5c9 3266 break;
4c4b4cd2
PH
3267
3268 case OP_TYPE:
b3dbf008 3269 case OP_REGISTER:
4c4b4cd2 3270 return NULL;
14f9c5c9
AS
3271 }
3272
3273 *pos = pc;
3274 return evaluate_subexp_type (exp, pos);
3275}
3276
3277/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3278 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3279 a non-pointer. */
14f9c5c9 3280/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3281 liberal. */
14f9c5c9
AS
3282
3283static int
4dc81987 3284ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3285{
61ee279c
PH
3286 ftype = ada_check_typedef (ftype);
3287 atype = ada_check_typedef (atype);
14f9c5c9
AS
3288
3289 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3290 ftype = TYPE_TARGET_TYPE (ftype);
3291 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3292 atype = TYPE_TARGET_TYPE (atype);
3293
d2e4a39e 3294 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3295 {
3296 default:
5b3d5b7d 3297 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3298 case TYPE_CODE_PTR:
3299 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3300 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3301 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3302 else
1265e4aa
JB
3303 return (may_deref
3304 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3305 case TYPE_CODE_INT:
3306 case TYPE_CODE_ENUM:
3307 case TYPE_CODE_RANGE:
3308 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3309 {
3310 case TYPE_CODE_INT:
3311 case TYPE_CODE_ENUM:
3312 case TYPE_CODE_RANGE:
3313 return 1;
3314 default:
3315 return 0;
3316 }
14f9c5c9
AS
3317
3318 case TYPE_CODE_ARRAY:
d2e4a39e 3319 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3320 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3321
3322 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3323 if (ada_is_array_descriptor_type (ftype))
3324 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3325 || ada_is_array_descriptor_type (atype));
14f9c5c9 3326 else
4c4b4cd2
PH
3327 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3328 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3329
3330 case TYPE_CODE_UNION:
3331 case TYPE_CODE_FLT:
3332 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3333 }
3334}
3335
3336/* Return non-zero if the formals of FUNC "sufficiently match" the
3337 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3338 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3339 argument function. */
14f9c5c9
AS
3340
3341static int
d2e4a39e 3342ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3343{
3344 int i;
d2e4a39e 3345 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3346
1265e4aa
JB
3347 if (SYMBOL_CLASS (func) == LOC_CONST
3348 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3349 return (n_actuals == 0);
3350 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3351 return 0;
3352
3353 if (TYPE_NFIELDS (func_type) != n_actuals)
3354 return 0;
3355
3356 for (i = 0; i < n_actuals; i += 1)
3357 {
4c4b4cd2 3358 if (actuals[i] == NULL)
76a01679
JB
3359 return 0;
3360 else
3361 {
5b4ee69b
MS
3362 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3363 i));
df407dfe 3364 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3365
76a01679
JB
3366 if (!ada_type_match (ftype, atype, 1))
3367 return 0;
3368 }
14f9c5c9
AS
3369 }
3370 return 1;
3371}
3372
3373/* False iff function type FUNC_TYPE definitely does not produce a value
3374 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3375 FUNC_TYPE is not a valid function type with a non-null return type
3376 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3377
3378static int
d2e4a39e 3379return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3380{
d2e4a39e 3381 struct type *return_type;
14f9c5c9
AS
3382
3383 if (func_type == NULL)
3384 return 1;
3385
4c4b4cd2 3386 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3387 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3388 else
18af8284 3389 return_type = get_base_type (func_type);
14f9c5c9
AS
3390 if (return_type == NULL)
3391 return 1;
3392
18af8284 3393 context_type = get_base_type (context_type);
14f9c5c9
AS
3394
3395 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3396 return context_type == NULL || return_type == context_type;
3397 else if (context_type == NULL)
3398 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3399 else
3400 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3401}
3402
3403
4c4b4cd2 3404/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3405 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3406 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3407 that returns that type, then eliminate matches that don't. If
3408 CONTEXT_TYPE is void and there is at least one match that does not
3409 return void, eliminate all matches that do.
3410
14f9c5c9
AS
3411 Asks the user if there is more than one match remaining. Returns -1
3412 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3413 solely for messages. May re-arrange and modify SYMS in
3414 the process; the index returned is for the modified vector. */
14f9c5c9 3415
4c4b4cd2
PH
3416static int
3417ada_resolve_function (struct ada_symbol_info syms[],
3418 int nsyms, struct value **args, int nargs,
3419 const char *name, struct type *context_type)
14f9c5c9 3420{
30b15541 3421 int fallback;
14f9c5c9 3422 int k;
4c4b4cd2 3423 int m; /* Number of hits */
14f9c5c9 3424
d2e4a39e 3425 m = 0;
30b15541
UW
3426 /* In the first pass of the loop, we only accept functions matching
3427 context_type. If none are found, we add a second pass of the loop
3428 where every function is accepted. */
3429 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3430 {
3431 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3432 {
61ee279c 3433 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
4c4b4cd2
PH
3434
3435 if (ada_args_match (syms[k].sym, args, nargs)
30b15541 3436 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3437 {
3438 syms[m] = syms[k];
3439 m += 1;
3440 }
3441 }
14f9c5c9
AS
3442 }
3443
3444 if (m == 0)
3445 return -1;
3446 else if (m > 1)
3447 {
323e0a4a 3448 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3449 user_select_syms (syms, m, 1);
14f9c5c9
AS
3450 return 0;
3451 }
3452 return 0;
3453}
3454
4c4b4cd2
PH
3455/* Returns true (non-zero) iff decoded name N0 should appear before N1
3456 in a listing of choices during disambiguation (see sort_choices, below).
3457 The idea is that overloadings of a subprogram name from the
3458 same package should sort in their source order. We settle for ordering
3459 such symbols by their trailing number (__N or $N). */
3460
14f9c5c9 3461static int
0d5cff50 3462encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3463{
3464 if (N1 == NULL)
3465 return 0;
3466 else if (N0 == NULL)
3467 return 1;
3468 else
3469 {
3470 int k0, k1;
5b4ee69b 3471
d2e4a39e 3472 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3473 ;
d2e4a39e 3474 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3475 ;
d2e4a39e 3476 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3477 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3478 {
3479 int n0, n1;
5b4ee69b 3480
4c4b4cd2
PH
3481 n0 = k0;
3482 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3483 n0 -= 1;
3484 n1 = k1;
3485 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3486 n1 -= 1;
3487 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3488 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3489 }
14f9c5c9
AS
3490 return (strcmp (N0, N1) < 0);
3491 }
3492}
d2e4a39e 3493
4c4b4cd2
PH
3494/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3495 encoded names. */
3496
d2e4a39e 3497static void
4c4b4cd2 3498sort_choices (struct ada_symbol_info syms[], int nsyms)
14f9c5c9 3499{
4c4b4cd2 3500 int i;
5b4ee69b 3501
d2e4a39e 3502 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3503 {
4c4b4cd2 3504 struct ada_symbol_info sym = syms[i];
14f9c5c9
AS
3505 int j;
3506
d2e4a39e 3507 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2
PH
3508 {
3509 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3510 SYMBOL_LINKAGE_NAME (sym.sym)))
3511 break;
3512 syms[j + 1] = syms[j];
3513 }
d2e4a39e 3514 syms[j + 1] = sym;
14f9c5c9
AS
3515 }
3516}
3517
4c4b4cd2
PH
3518/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3519 by asking the user (if necessary), returning the number selected,
3520 and setting the first elements of SYMS items. Error if no symbols
3521 selected. */
14f9c5c9
AS
3522
3523/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3524 to be re-integrated one of these days. */
14f9c5c9
AS
3525
3526int
4c4b4cd2 3527user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
14f9c5c9
AS
3528{
3529 int i;
d2e4a39e 3530 int *chosen = (int *) alloca (sizeof (int) * nsyms);
14f9c5c9
AS
3531 int n_chosen;
3532 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3533 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3534
3535 if (max_results < 1)
323e0a4a 3536 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3537 if (nsyms <= 1)
3538 return nsyms;
3539
717d2f5a
JB
3540 if (select_mode == multiple_symbols_cancel)
3541 error (_("\
3542canceled because the command is ambiguous\n\
3543See set/show multiple-symbol."));
3544
3545 /* If select_mode is "all", then return all possible symbols.
3546 Only do that if more than one symbol can be selected, of course.
3547 Otherwise, display the menu as usual. */
3548 if (select_mode == multiple_symbols_all && max_results > 1)
3549 return nsyms;
3550
323e0a4a 3551 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3552 if (max_results > 1)
323e0a4a 3553 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3554
4c4b4cd2 3555 sort_choices (syms, nsyms);
14f9c5c9
AS
3556
3557 for (i = 0; i < nsyms; i += 1)
3558 {
4c4b4cd2
PH
3559 if (syms[i].sym == NULL)
3560 continue;
3561
3562 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3563 {
76a01679
JB
3564 struct symtab_and_line sal =
3565 find_function_start_sal (syms[i].sym, 1);
5b4ee69b 3566
323e0a4a
AC
3567 if (sal.symtab == NULL)
3568 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3569 i + first_choice,
3570 SYMBOL_PRINT_NAME (syms[i].sym),
3571 sal.line);
3572 else
3573 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3574 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821
JK
3575 symtab_to_filename_for_display (sal.symtab),
3576 sal.line);
4c4b4cd2
PH
3577 continue;
3578 }
d2e4a39e 3579 else
4c4b4cd2
PH
3580 {
3581 int is_enumeral =
3582 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3583 && SYMBOL_TYPE (syms[i].sym) != NULL
3584 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
210bbc17 3585 struct symtab *symtab = SYMBOL_SYMTAB (syms[i].sym);
4c4b4cd2
PH
3586
3587 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
323e0a4a 3588 printf_unfiltered (_("[%d] %s at %s:%d\n"),
4c4b4cd2
PH
3589 i + first_choice,
3590 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821
JK
3591 symtab_to_filename_for_display (symtab),
3592 SYMBOL_LINE (syms[i].sym));
76a01679
JB
3593 else if (is_enumeral
3594 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
4c4b4cd2 3595 {
a3f17187 3596 printf_unfiltered (("[%d] "), i + first_choice);
76a01679 3597 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
79d43c61 3598 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3599 printf_unfiltered (_("'(%s) (enumeral)\n"),
4c4b4cd2
PH
3600 SYMBOL_PRINT_NAME (syms[i].sym));
3601 }
3602 else if (symtab != NULL)
3603 printf_unfiltered (is_enumeral
323e0a4a
AC
3604 ? _("[%d] %s in %s (enumeral)\n")
3605 : _("[%d] %s at %s:?\n"),
4c4b4cd2
PH
3606 i + first_choice,
3607 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821 3608 symtab_to_filename_for_display (symtab));
4c4b4cd2
PH
3609 else
3610 printf_unfiltered (is_enumeral
323e0a4a
AC
3611 ? _("[%d] %s (enumeral)\n")
3612 : _("[%d] %s at ?\n"),
4c4b4cd2
PH
3613 i + first_choice,
3614 SYMBOL_PRINT_NAME (syms[i].sym));
3615 }
14f9c5c9 3616 }
d2e4a39e 3617
14f9c5c9 3618 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 3619 "overload-choice");
14f9c5c9
AS
3620
3621 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 3622 syms[i] = syms[chosen[i]];
14f9c5c9
AS
3623
3624 return n_chosen;
3625}
3626
3627/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 3628 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
3629 order in CHOICES[0 .. N-1], and return N.
3630
3631 The user types choices as a sequence of numbers on one line
3632 separated by blanks, encoding them as follows:
3633
4c4b4cd2 3634 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
3635 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3636 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3637
4c4b4cd2 3638 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
3639
3640 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 3641 prompts (for use with the -f switch). */
14f9c5c9
AS
3642
3643int
d2e4a39e 3644get_selections (int *choices, int n_choices, int max_results,
4c4b4cd2 3645 int is_all_choice, char *annotation_suffix)
14f9c5c9 3646{
d2e4a39e 3647 char *args;
0bcd0149 3648 char *prompt;
14f9c5c9
AS
3649 int n_chosen;
3650 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 3651
14f9c5c9
AS
3652 prompt = getenv ("PS2");
3653 if (prompt == NULL)
0bcd0149 3654 prompt = "> ";
14f9c5c9 3655
0bcd0149 3656 args = command_line_input (prompt, 0, annotation_suffix);
d2e4a39e 3657
14f9c5c9 3658 if (args == NULL)
323e0a4a 3659 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
3660
3661 n_chosen = 0;
76a01679 3662
4c4b4cd2
PH
3663 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3664 order, as given in args. Choices are validated. */
14f9c5c9
AS
3665 while (1)
3666 {
d2e4a39e 3667 char *args2;
14f9c5c9
AS
3668 int choice, j;
3669
0fcd72ba 3670 args = skip_spaces (args);
14f9c5c9 3671 if (*args == '\0' && n_chosen == 0)
323e0a4a 3672 error_no_arg (_("one or more choice numbers"));
14f9c5c9 3673 else if (*args == '\0')
4c4b4cd2 3674 break;
14f9c5c9
AS
3675
3676 choice = strtol (args, &args2, 10);
d2e4a39e 3677 if (args == args2 || choice < 0
4c4b4cd2 3678 || choice > n_choices + first_choice - 1)
323e0a4a 3679 error (_("Argument must be choice number"));
14f9c5c9
AS
3680 args = args2;
3681
d2e4a39e 3682 if (choice == 0)
323e0a4a 3683 error (_("cancelled"));
14f9c5c9
AS
3684
3685 if (choice < first_choice)
4c4b4cd2
PH
3686 {
3687 n_chosen = n_choices;
3688 for (j = 0; j < n_choices; j += 1)
3689 choices[j] = j;
3690 break;
3691 }
14f9c5c9
AS
3692 choice -= first_choice;
3693
d2e4a39e 3694 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
3695 {
3696 }
14f9c5c9
AS
3697
3698 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
3699 {
3700 int k;
5b4ee69b 3701
4c4b4cd2
PH
3702 for (k = n_chosen - 1; k > j; k -= 1)
3703 choices[k + 1] = choices[k];
3704 choices[j + 1] = choice;
3705 n_chosen += 1;
3706 }
14f9c5c9
AS
3707 }
3708
3709 if (n_chosen > max_results)
323e0a4a 3710 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 3711
14f9c5c9
AS
3712 return n_chosen;
3713}
3714
4c4b4cd2
PH
3715/* Replace the operator of length OPLEN at position PC in *EXPP with a call
3716 on the function identified by SYM and BLOCK, and taking NARGS
3717 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
3718
3719static void
d2e4a39e 3720replace_operator_with_call (struct expression **expp, int pc, int nargs,
4c4b4cd2 3721 int oplen, struct symbol *sym,
270140bd 3722 const struct block *block)
14f9c5c9
AS
3723{
3724 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 3725 symbol, -oplen for operator being replaced). */
d2e4a39e 3726 struct expression *newexp = (struct expression *)
8c1a34e7 3727 xzalloc (sizeof (struct expression)
4c4b4cd2 3728 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
d2e4a39e 3729 struct expression *exp = *expp;
14f9c5c9
AS
3730
3731 newexp->nelts = exp->nelts + 7 - oplen;
3732 newexp->language_defn = exp->language_defn;
3489610d 3733 newexp->gdbarch = exp->gdbarch;
14f9c5c9 3734 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 3735 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 3736 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
3737
3738 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3739 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3740
3741 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3742 newexp->elts[pc + 4].block = block;
3743 newexp->elts[pc + 5].symbol = sym;
3744
3745 *expp = newexp;
aacb1f0a 3746 xfree (exp);
d2e4a39e 3747}
14f9c5c9
AS
3748
3749/* Type-class predicates */
3750
4c4b4cd2
PH
3751/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3752 or FLOAT). */
14f9c5c9
AS
3753
3754static int
d2e4a39e 3755numeric_type_p (struct type *type)
14f9c5c9
AS
3756{
3757 if (type == NULL)
3758 return 0;
d2e4a39e
AS
3759 else
3760 {
3761 switch (TYPE_CODE (type))
4c4b4cd2
PH
3762 {
3763 case TYPE_CODE_INT:
3764 case TYPE_CODE_FLT:
3765 return 1;
3766 case TYPE_CODE_RANGE:
3767 return (type == TYPE_TARGET_TYPE (type)
3768 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3769 default:
3770 return 0;
3771 }
d2e4a39e 3772 }
14f9c5c9
AS
3773}
3774
4c4b4cd2 3775/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
3776
3777static int
d2e4a39e 3778integer_type_p (struct type *type)
14f9c5c9
AS
3779{
3780 if (type == NULL)
3781 return 0;
d2e4a39e
AS
3782 else
3783 {
3784 switch (TYPE_CODE (type))
4c4b4cd2
PH
3785 {
3786 case TYPE_CODE_INT:
3787 return 1;
3788 case TYPE_CODE_RANGE:
3789 return (type == TYPE_TARGET_TYPE (type)
3790 || integer_type_p (TYPE_TARGET_TYPE (type)));
3791 default:
3792 return 0;
3793 }
d2e4a39e 3794 }
14f9c5c9
AS
3795}
3796
4c4b4cd2 3797/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
3798
3799static int
d2e4a39e 3800scalar_type_p (struct type *type)
14f9c5c9
AS
3801{
3802 if (type == NULL)
3803 return 0;
d2e4a39e
AS
3804 else
3805 {
3806 switch (TYPE_CODE (type))
4c4b4cd2
PH
3807 {
3808 case TYPE_CODE_INT:
3809 case TYPE_CODE_RANGE:
3810 case TYPE_CODE_ENUM:
3811 case TYPE_CODE_FLT:
3812 return 1;
3813 default:
3814 return 0;
3815 }
d2e4a39e 3816 }
14f9c5c9
AS
3817}
3818
4c4b4cd2 3819/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
3820
3821static int
d2e4a39e 3822discrete_type_p (struct type *type)
14f9c5c9
AS
3823{
3824 if (type == NULL)
3825 return 0;
d2e4a39e
AS
3826 else
3827 {
3828 switch (TYPE_CODE (type))
4c4b4cd2
PH
3829 {
3830 case TYPE_CODE_INT:
3831 case TYPE_CODE_RANGE:
3832 case TYPE_CODE_ENUM:
872f0337 3833 case TYPE_CODE_BOOL:
4c4b4cd2
PH
3834 return 1;
3835 default:
3836 return 0;
3837 }
d2e4a39e 3838 }
14f9c5c9
AS
3839}
3840
4c4b4cd2
PH
3841/* Returns non-zero if OP with operands in the vector ARGS could be
3842 a user-defined function. Errs on the side of pre-defined operators
3843 (i.e., result 0). */
14f9c5c9
AS
3844
3845static int
d2e4a39e 3846possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 3847{
76a01679 3848 struct type *type0 =
df407dfe 3849 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 3850 struct type *type1 =
df407dfe 3851 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 3852
4c4b4cd2
PH
3853 if (type0 == NULL)
3854 return 0;
3855
14f9c5c9
AS
3856 switch (op)
3857 {
3858 default:
3859 return 0;
3860
3861 case BINOP_ADD:
3862 case BINOP_SUB:
3863 case BINOP_MUL:
3864 case BINOP_DIV:
d2e4a39e 3865 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
3866
3867 case BINOP_REM:
3868 case BINOP_MOD:
3869 case BINOP_BITWISE_AND:
3870 case BINOP_BITWISE_IOR:
3871 case BINOP_BITWISE_XOR:
d2e4a39e 3872 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3873
3874 case BINOP_EQUAL:
3875 case BINOP_NOTEQUAL:
3876 case BINOP_LESS:
3877 case BINOP_GTR:
3878 case BINOP_LEQ:
3879 case BINOP_GEQ:
d2e4a39e 3880 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
3881
3882 case BINOP_CONCAT:
ee90b9ab 3883 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
3884
3885 case BINOP_EXP:
d2e4a39e 3886 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3887
3888 case UNOP_NEG:
3889 case UNOP_PLUS:
3890 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
3891 case UNOP_ABS:
3892 return (!numeric_type_p (type0));
14f9c5c9
AS
3893
3894 }
3895}
3896\f
4c4b4cd2 3897 /* Renaming */
14f9c5c9 3898
aeb5907d
JB
3899/* NOTES:
3900
3901 1. In the following, we assume that a renaming type's name may
3902 have an ___XD suffix. It would be nice if this went away at some
3903 point.
3904 2. We handle both the (old) purely type-based representation of
3905 renamings and the (new) variable-based encoding. At some point,
3906 it is devoutly to be hoped that the former goes away
3907 (FIXME: hilfinger-2007-07-09).
3908 3. Subprogram renamings are not implemented, although the XRS
3909 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3910
3911/* If SYM encodes a renaming,
3912
3913 <renaming> renames <renamed entity>,
3914
3915 sets *LEN to the length of the renamed entity's name,
3916 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3917 the string describing the subcomponent selected from the renamed
0963b4bd 3918 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
3919 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3920 are undefined). Otherwise, returns a value indicating the category
3921 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3922 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3923 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3924 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3925 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3926 may be NULL, in which case they are not assigned.
3927
3928 [Currently, however, GCC does not generate subprogram renamings.] */
3929
3930enum ada_renaming_category
3931ada_parse_renaming (struct symbol *sym,
3932 const char **renamed_entity, int *len,
3933 const char **renaming_expr)
3934{
3935 enum ada_renaming_category kind;
3936 const char *info;
3937 const char *suffix;
3938
3939 if (sym == NULL)
3940 return ADA_NOT_RENAMING;
3941 switch (SYMBOL_CLASS (sym))
14f9c5c9 3942 {
aeb5907d
JB
3943 default:
3944 return ADA_NOT_RENAMING;
3945 case LOC_TYPEDEF:
3946 return parse_old_style_renaming (SYMBOL_TYPE (sym),
3947 renamed_entity, len, renaming_expr);
3948 case LOC_LOCAL:
3949 case LOC_STATIC:
3950 case LOC_COMPUTED:
3951 case LOC_OPTIMIZED_OUT:
3952 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
3953 if (info == NULL)
3954 return ADA_NOT_RENAMING;
3955 switch (info[5])
3956 {
3957 case '_':
3958 kind = ADA_OBJECT_RENAMING;
3959 info += 6;
3960 break;
3961 case 'E':
3962 kind = ADA_EXCEPTION_RENAMING;
3963 info += 7;
3964 break;
3965 case 'P':
3966 kind = ADA_PACKAGE_RENAMING;
3967 info += 7;
3968 break;
3969 case 'S':
3970 kind = ADA_SUBPROGRAM_RENAMING;
3971 info += 7;
3972 break;
3973 default:
3974 return ADA_NOT_RENAMING;
3975 }
14f9c5c9 3976 }
4c4b4cd2 3977
aeb5907d
JB
3978 if (renamed_entity != NULL)
3979 *renamed_entity = info;
3980 suffix = strstr (info, "___XE");
3981 if (suffix == NULL || suffix == info)
3982 return ADA_NOT_RENAMING;
3983 if (len != NULL)
3984 *len = strlen (info) - strlen (suffix);
3985 suffix += 5;
3986 if (renaming_expr != NULL)
3987 *renaming_expr = suffix;
3988 return kind;
3989}
3990
3991/* Assuming TYPE encodes a renaming according to the old encoding in
3992 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3993 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3994 ADA_NOT_RENAMING otherwise. */
3995static enum ada_renaming_category
3996parse_old_style_renaming (struct type *type,
3997 const char **renamed_entity, int *len,
3998 const char **renaming_expr)
3999{
4000 enum ada_renaming_category kind;
4001 const char *name;
4002 const char *info;
4003 const char *suffix;
14f9c5c9 4004
aeb5907d
JB
4005 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4006 || TYPE_NFIELDS (type) != 1)
4007 return ADA_NOT_RENAMING;
14f9c5c9 4008
aeb5907d
JB
4009 name = type_name_no_tag (type);
4010 if (name == NULL)
4011 return ADA_NOT_RENAMING;
4012
4013 name = strstr (name, "___XR");
4014 if (name == NULL)
4015 return ADA_NOT_RENAMING;
4016 switch (name[5])
4017 {
4018 case '\0':
4019 case '_':
4020 kind = ADA_OBJECT_RENAMING;
4021 break;
4022 case 'E':
4023 kind = ADA_EXCEPTION_RENAMING;
4024 break;
4025 case 'P':
4026 kind = ADA_PACKAGE_RENAMING;
4027 break;
4028 case 'S':
4029 kind = ADA_SUBPROGRAM_RENAMING;
4030 break;
4031 default:
4032 return ADA_NOT_RENAMING;
4033 }
14f9c5c9 4034
aeb5907d
JB
4035 info = TYPE_FIELD_NAME (type, 0);
4036 if (info == NULL)
4037 return ADA_NOT_RENAMING;
4038 if (renamed_entity != NULL)
4039 *renamed_entity = info;
4040 suffix = strstr (info, "___XE");
4041 if (renaming_expr != NULL)
4042 *renaming_expr = suffix + 5;
4043 if (suffix == NULL || suffix == info)
4044 return ADA_NOT_RENAMING;
4045 if (len != NULL)
4046 *len = suffix - info;
4047 return kind;
a5ee536b
JB
4048}
4049
4050/* Compute the value of the given RENAMING_SYM, which is expected to
4051 be a symbol encoding a renaming expression. BLOCK is the block
4052 used to evaluate the renaming. */
52ce6436 4053
a5ee536b
JB
4054static struct value *
4055ada_read_renaming_var_value (struct symbol *renaming_sym,
4056 struct block *block)
4057{
bbc13ae3 4058 const char *sym_name;
a5ee536b
JB
4059 struct expression *expr;
4060 struct value *value;
4061 struct cleanup *old_chain = NULL;
4062
bbc13ae3 4063 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
1bb9788d 4064 expr = parse_exp_1 (&sym_name, 0, block, 0);
bbc13ae3 4065 old_chain = make_cleanup (free_current_contents, &expr);
a5ee536b
JB
4066 value = evaluate_expression (expr);
4067
4068 do_cleanups (old_chain);
4069 return value;
4070}
14f9c5c9 4071\f
d2e4a39e 4072
4c4b4cd2 4073 /* Evaluation: Function Calls */
14f9c5c9 4074
4c4b4cd2 4075/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4076 lvalues, and otherwise has the side-effect of allocating memory
4077 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4078
d2e4a39e 4079static struct value *
40bc484c 4080ensure_lval (struct value *val)
14f9c5c9 4081{
40bc484c
JB
4082 if (VALUE_LVAL (val) == not_lval
4083 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4084 {
df407dfe 4085 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4086 const CORE_ADDR addr =
4087 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4088
40bc484c 4089 set_value_address (val, addr);
a84a8a0d 4090 VALUE_LVAL (val) = lval_memory;
40bc484c 4091 write_memory (addr, value_contents (val), len);
c3e5cd34 4092 }
14f9c5c9
AS
4093
4094 return val;
4095}
4096
4097/* Return the value ACTUAL, converted to be an appropriate value for a
4098 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4099 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4100 values not residing in memory, updating it as needed. */
14f9c5c9 4101
a93c0eb6 4102struct value *
40bc484c 4103ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4104{
df407dfe 4105 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4106 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4107 struct type *formal_target =
4108 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4109 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4110 struct type *actual_target =
4111 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4112 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4113
4c4b4cd2 4114 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4115 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4116 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4117 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4118 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4119 {
a84a8a0d 4120 struct value *result;
5b4ee69b 4121
14f9c5c9 4122 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4123 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4124 result = desc_data (actual);
14f9c5c9 4125 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4126 {
4127 if (VALUE_LVAL (actual) != lval_memory)
4128 {
4129 struct value *val;
5b4ee69b 4130
df407dfe 4131 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4132 val = allocate_value (actual_type);
990a07ab 4133 memcpy ((char *) value_contents_raw (val),
0fd88904 4134 (char *) value_contents (actual),
4c4b4cd2 4135 TYPE_LENGTH (actual_type));
40bc484c 4136 actual = ensure_lval (val);
4c4b4cd2 4137 }
a84a8a0d 4138 result = value_addr (actual);
4c4b4cd2 4139 }
a84a8a0d
JB
4140 else
4141 return actual;
b1af9e97 4142 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4143 }
4144 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4145 return ada_value_ind (actual);
4146
4147 return actual;
4148}
4149
438c98a1
JB
4150/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4151 type TYPE. This is usually an inefficient no-op except on some targets
4152 (such as AVR) where the representation of a pointer and an address
4153 differs. */
4154
4155static CORE_ADDR
4156value_pointer (struct value *value, struct type *type)
4157{
4158 struct gdbarch *gdbarch = get_type_arch (type);
4159 unsigned len = TYPE_LENGTH (type);
4160 gdb_byte *buf = alloca (len);
4161 CORE_ADDR addr;
4162
4163 addr = value_address (value);
4164 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4165 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4166 return addr;
4167}
4168
14f9c5c9 4169
4c4b4cd2
PH
4170/* Push a descriptor of type TYPE for array value ARR on the stack at
4171 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4172 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4173 to-descriptor type rather than a descriptor type), a struct value *
4174 representing a pointer to this descriptor. */
14f9c5c9 4175
d2e4a39e 4176static struct value *
40bc484c 4177make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4178{
d2e4a39e
AS
4179 struct type *bounds_type = desc_bounds_type (type);
4180 struct type *desc_type = desc_base_type (type);
4181 struct value *descriptor = allocate_value (desc_type);
4182 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4183 int i;
d2e4a39e 4184
0963b4bd
MS
4185 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4186 i > 0; i -= 1)
14f9c5c9 4187 {
19f220c3
JK
4188 modify_field (value_type (bounds), value_contents_writeable (bounds),
4189 ada_array_bound (arr, i, 0),
4190 desc_bound_bitpos (bounds_type, i, 0),
4191 desc_bound_bitsize (bounds_type, i, 0));
4192 modify_field (value_type (bounds), value_contents_writeable (bounds),
4193 ada_array_bound (arr, i, 1),
4194 desc_bound_bitpos (bounds_type, i, 1),
4195 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4196 }
d2e4a39e 4197
40bc484c 4198 bounds = ensure_lval (bounds);
d2e4a39e 4199
19f220c3
JK
4200 modify_field (value_type (descriptor),
4201 value_contents_writeable (descriptor),
4202 value_pointer (ensure_lval (arr),
4203 TYPE_FIELD_TYPE (desc_type, 0)),
4204 fat_pntr_data_bitpos (desc_type),
4205 fat_pntr_data_bitsize (desc_type));
4206
4207 modify_field (value_type (descriptor),
4208 value_contents_writeable (descriptor),
4209 value_pointer (bounds,
4210 TYPE_FIELD_TYPE (desc_type, 1)),
4211 fat_pntr_bounds_bitpos (desc_type),
4212 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4213
40bc484c 4214 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4215
4216 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4217 return value_addr (descriptor);
4218 else
4219 return descriptor;
4220}
14f9c5c9 4221\f
963a6417 4222/* Dummy definitions for an experimental caching module that is not
0963b4bd 4223 * used in the public sources. */
96d887e8 4224
96d887e8
PH
4225static int
4226lookup_cached_symbol (const char *name, domain_enum namespace,
2570f2b7 4227 struct symbol **sym, struct block **block)
96d887e8
PH
4228{
4229 return 0;
4230}
4231
4232static void
4233cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
270140bd 4234 const struct block *block)
96d887e8
PH
4235{
4236}
4c4b4cd2
PH
4237\f
4238 /* Symbol Lookup */
4239
c0431670
JB
4240/* Return nonzero if wild matching should be used when searching for
4241 all symbols matching LOOKUP_NAME.
4242
4243 LOOKUP_NAME is expected to be a symbol name after transformation
4244 for Ada lookups (see ada_name_for_lookup). */
4245
4246static int
4247should_use_wild_match (const char *lookup_name)
4248{
4249 return (strstr (lookup_name, "__") == NULL);
4250}
4251
4c4b4cd2
PH
4252/* Return the result of a standard (literal, C-like) lookup of NAME in
4253 given DOMAIN, visible from lexical block BLOCK. */
4254
4255static struct symbol *
4256standard_lookup (const char *name, const struct block *block,
4257 domain_enum domain)
4258{
acbd605d
MGD
4259 /* Initialize it just to avoid a GCC false warning. */
4260 struct symbol *sym = NULL;
4c4b4cd2 4261
2570f2b7 4262 if (lookup_cached_symbol (name, domain, &sym, NULL))
4c4b4cd2 4263 return sym;
2570f2b7
UW
4264 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4265 cache_symbol (name, domain, sym, block_found);
4c4b4cd2
PH
4266 return sym;
4267}
4268
4269
4270/* Non-zero iff there is at least one non-function/non-enumeral symbol
4271 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4272 since they contend in overloading in the same way. */
4273static int
4274is_nonfunction (struct ada_symbol_info syms[], int n)
4275{
4276 int i;
4277
4278 for (i = 0; i < n; i += 1)
4279 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
4280 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
4281 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
14f9c5c9
AS
4282 return 1;
4283
4284 return 0;
4285}
4286
4287/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4288 struct types. Otherwise, they may not. */
14f9c5c9
AS
4289
4290static int
d2e4a39e 4291equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4292{
d2e4a39e 4293 if (type0 == type1)
14f9c5c9 4294 return 1;
d2e4a39e 4295 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4296 || TYPE_CODE (type0) != TYPE_CODE (type1))
4297 return 0;
d2e4a39e 4298 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4299 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4300 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4301 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4302 return 1;
d2e4a39e 4303
14f9c5c9
AS
4304 return 0;
4305}
4306
4307/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4308 no more defined than that of SYM1. */
14f9c5c9
AS
4309
4310static int
d2e4a39e 4311lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4312{
4313 if (sym0 == sym1)
4314 return 1;
176620f1 4315 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4316 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4317 return 0;
4318
d2e4a39e 4319 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4320 {
4321 case LOC_UNDEF:
4322 return 1;
4323 case LOC_TYPEDEF:
4324 {
4c4b4cd2
PH
4325 struct type *type0 = SYMBOL_TYPE (sym0);
4326 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4327 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4328 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4329 int len0 = strlen (name0);
5b4ee69b 4330
4c4b4cd2
PH
4331 return
4332 TYPE_CODE (type0) == TYPE_CODE (type1)
4333 && (equiv_types (type0, type1)
4334 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4335 && strncmp (name1 + len0, "___XV", 5) == 0));
14f9c5c9
AS
4336 }
4337 case LOC_CONST:
4338 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4339 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4340 default:
4341 return 0;
14f9c5c9
AS
4342 }
4343}
4344
4c4b4cd2
PH
4345/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4346 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4347
4348static void
76a01679
JB
4349add_defn_to_vec (struct obstack *obstackp,
4350 struct symbol *sym,
2570f2b7 4351 struct block *block)
14f9c5c9
AS
4352{
4353 int i;
4c4b4cd2 4354 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4355
529cad9c
PH
4356 /* Do not try to complete stub types, as the debugger is probably
4357 already scanning all symbols matching a certain name at the
4358 time when this function is called. Trying to replace the stub
4359 type by its associated full type will cause us to restart a scan
4360 which may lead to an infinite recursion. Instead, the client
4361 collecting the matching symbols will end up collecting several
4362 matches, with at least one of them complete. It can then filter
4363 out the stub ones if needed. */
4364
4c4b4cd2
PH
4365 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4366 {
4367 if (lesseq_defined_than (sym, prevDefns[i].sym))
4368 return;
4369 else if (lesseq_defined_than (prevDefns[i].sym, sym))
4370 {
4371 prevDefns[i].sym = sym;
4372 prevDefns[i].block = block;
4c4b4cd2 4373 return;
76a01679 4374 }
4c4b4cd2
PH
4375 }
4376
4377 {
4378 struct ada_symbol_info info;
4379
4380 info.sym = sym;
4381 info.block = block;
4c4b4cd2
PH
4382 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
4383 }
4384}
4385
4386/* Number of ada_symbol_info structures currently collected in
4387 current vector in *OBSTACKP. */
4388
76a01679
JB
4389static int
4390num_defns_collected (struct obstack *obstackp)
4c4b4cd2
PH
4391{
4392 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
4393}
4394
4395/* Vector of ada_symbol_info structures currently collected in current
4396 vector in *OBSTACKP. If FINISH, close off the vector and return
4397 its final address. */
4398
76a01679 4399static struct ada_symbol_info *
4c4b4cd2
PH
4400defns_collected (struct obstack *obstackp, int finish)
4401{
4402 if (finish)
4403 return obstack_finish (obstackp);
4404 else
4405 return (struct ada_symbol_info *) obstack_base (obstackp);
4406}
4407
96d887e8 4408/* Return a minimal symbol matching NAME according to Ada decoding
2e6e0353
JB
4409 rules. Returns NULL if there is no such minimal symbol. Names
4410 prefixed with "standard__" are handled specially: "standard__" is
96d887e8 4411 first stripped off, and only static and global symbols are searched. */
4c4b4cd2 4412
96d887e8
PH
4413struct minimal_symbol *
4414ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4415{
4c4b4cd2 4416 struct objfile *objfile;
96d887e8 4417 struct minimal_symbol *msymbol;
dc4024cd 4418 const int wild_match_p = should_use_wild_match (name);
4c4b4cd2 4419
c0431670
JB
4420 /* Special case: If the user specifies a symbol name inside package
4421 Standard, do a non-wild matching of the symbol name without
4422 the "standard__" prefix. This was primarily introduced in order
4423 to allow the user to specifically access the standard exceptions
4424 using, for instance, Standard.Constraint_Error when Constraint_Error
4425 is ambiguous (due to the user defining its own Constraint_Error
4426 entity inside its program). */
96d887e8 4427 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
c0431670 4428 name += sizeof ("standard__") - 1;
4c4b4cd2 4429
96d887e8
PH
4430 ALL_MSYMBOLS (objfile, msymbol)
4431 {
dc4024cd 4432 if (match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match_p)
96d887e8
PH
4433 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4434 return msymbol;
4435 }
4c4b4cd2 4436
96d887e8
PH
4437 return NULL;
4438}
4c4b4cd2 4439
96d887e8
PH
4440/* For all subprograms that statically enclose the subprogram of the
4441 selected frame, add symbols matching identifier NAME in DOMAIN
4442 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4443 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4444 with a wildcard prefix. */
4c4b4cd2 4445
96d887e8
PH
4446static void
4447add_symbols_from_enclosing_procs (struct obstack *obstackp,
76a01679 4448 const char *name, domain_enum namespace,
48b78332 4449 int wild_match_p)
96d887e8 4450{
96d887e8 4451}
14f9c5c9 4452
96d887e8
PH
4453/* True if TYPE is definitely an artificial type supplied to a symbol
4454 for which no debugging information was given in the symbol file. */
14f9c5c9 4455
96d887e8
PH
4456static int
4457is_nondebugging_type (struct type *type)
4458{
0d5cff50 4459 const char *name = ada_type_name (type);
5b4ee69b 4460
96d887e8
PH
4461 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4462}
4c4b4cd2 4463
8f17729f
JB
4464/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4465 that are deemed "identical" for practical purposes.
4466
4467 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4468 types and that their number of enumerals is identical (in other
4469 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4470
4471static int
4472ada_identical_enum_types_p (struct type *type1, struct type *type2)
4473{
4474 int i;
4475
4476 /* The heuristic we use here is fairly conservative. We consider
4477 that 2 enumerate types are identical if they have the same
4478 number of enumerals and that all enumerals have the same
4479 underlying value and name. */
4480
4481 /* All enums in the type should have an identical underlying value. */
4482 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 4483 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
4484 return 0;
4485
4486 /* All enumerals should also have the same name (modulo any numerical
4487 suffix). */
4488 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4489 {
0d5cff50
DE
4490 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4491 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
4492 int len_1 = strlen (name_1);
4493 int len_2 = strlen (name_2);
4494
4495 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4496 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4497 if (len_1 != len_2
4498 || strncmp (TYPE_FIELD_NAME (type1, i),
4499 TYPE_FIELD_NAME (type2, i),
4500 len_1) != 0)
4501 return 0;
4502 }
4503
4504 return 1;
4505}
4506
4507/* Return nonzero if all the symbols in SYMS are all enumeral symbols
4508 that are deemed "identical" for practical purposes. Sometimes,
4509 enumerals are not strictly identical, but their types are so similar
4510 that they can be considered identical.
4511
4512 For instance, consider the following code:
4513
4514 type Color is (Black, Red, Green, Blue, White);
4515 type RGB_Color is new Color range Red .. Blue;
4516
4517 Type RGB_Color is a subrange of an implicit type which is a copy
4518 of type Color. If we call that implicit type RGB_ColorB ("B" is
4519 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4520 As a result, when an expression references any of the enumeral
4521 by name (Eg. "print green"), the expression is technically
4522 ambiguous and the user should be asked to disambiguate. But
4523 doing so would only hinder the user, since it wouldn't matter
4524 what choice he makes, the outcome would always be the same.
4525 So, for practical purposes, we consider them as the same. */
4526
4527static int
4528symbols_are_identical_enums (struct ada_symbol_info *syms, int nsyms)
4529{
4530 int i;
4531
4532 /* Before performing a thorough comparison check of each type,
4533 we perform a series of inexpensive checks. We expect that these
4534 checks will quickly fail in the vast majority of cases, and thus
4535 help prevent the unnecessary use of a more expensive comparison.
4536 Said comparison also expects us to make some of these checks
4537 (see ada_identical_enum_types_p). */
4538
4539 /* Quick check: All symbols should have an enum type. */
4540 for (i = 0; i < nsyms; i++)
4541 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM)
4542 return 0;
4543
4544 /* Quick check: They should all have the same value. */
4545 for (i = 1; i < nsyms; i++)
4546 if (SYMBOL_VALUE (syms[i].sym) != SYMBOL_VALUE (syms[0].sym))
4547 return 0;
4548
4549 /* Quick check: They should all have the same number of enumerals. */
4550 for (i = 1; i < nsyms; i++)
4551 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].sym))
4552 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].sym)))
4553 return 0;
4554
4555 /* All the sanity checks passed, so we might have a set of
4556 identical enumeration types. Perform a more complete
4557 comparison of the type of each symbol. */
4558 for (i = 1; i < nsyms; i++)
4559 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].sym),
4560 SYMBOL_TYPE (syms[0].sym)))
4561 return 0;
4562
4563 return 1;
4564}
4565
96d887e8
PH
4566/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4567 duplicate other symbols in the list (The only case I know of where
4568 this happens is when object files containing stabs-in-ecoff are
4569 linked with files containing ordinary ecoff debugging symbols (or no
4570 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4571 Returns the number of items in the modified list. */
4c4b4cd2 4572
96d887e8
PH
4573static int
4574remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4575{
4576 int i, j;
4c4b4cd2 4577
8f17729f
JB
4578 /* We should never be called with less than 2 symbols, as there
4579 cannot be any extra symbol in that case. But it's easy to
4580 handle, since we have nothing to do in that case. */
4581 if (nsyms < 2)
4582 return nsyms;
4583
96d887e8
PH
4584 i = 0;
4585 while (i < nsyms)
4586 {
a35ddb44 4587 int remove_p = 0;
339c13b6
JB
4588
4589 /* If two symbols have the same name and one of them is a stub type,
4590 the get rid of the stub. */
4591
4592 if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym))
4593 && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL)
4594 {
4595 for (j = 0; j < nsyms; j++)
4596 {
4597 if (j != i
4598 && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym))
4599 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4600 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4601 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0)
a35ddb44 4602 remove_p = 1;
339c13b6
JB
4603 }
4604 }
4605
4606 /* Two symbols with the same name, same class and same address
4607 should be identical. */
4608
4609 else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
96d887e8
PH
4610 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4611 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4612 {
4613 for (j = 0; j < nsyms; j += 1)
4614 {
4615 if (i != j
4616 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4617 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
76a01679 4618 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
96d887e8
PH
4619 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4620 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4621 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
a35ddb44 4622 remove_p = 1;
4c4b4cd2 4623 }
4c4b4cd2 4624 }
339c13b6 4625
a35ddb44 4626 if (remove_p)
339c13b6
JB
4627 {
4628 for (j = i + 1; j < nsyms; j += 1)
4629 syms[j - 1] = syms[j];
4630 nsyms -= 1;
4631 }
4632
96d887e8 4633 i += 1;
14f9c5c9 4634 }
8f17729f
JB
4635
4636 /* If all the remaining symbols are identical enumerals, then
4637 just keep the first one and discard the rest.
4638
4639 Unlike what we did previously, we do not discard any entry
4640 unless they are ALL identical. This is because the symbol
4641 comparison is not a strict comparison, but rather a practical
4642 comparison. If all symbols are considered identical, then
4643 we can just go ahead and use the first one and discard the rest.
4644 But if we cannot reduce the list to a single element, we have
4645 to ask the user to disambiguate anyways. And if we have to
4646 present a multiple-choice menu, it's less confusing if the list
4647 isn't missing some choices that were identical and yet distinct. */
4648 if (symbols_are_identical_enums (syms, nsyms))
4649 nsyms = 1;
4650
96d887e8 4651 return nsyms;
14f9c5c9
AS
4652}
4653
96d887e8
PH
4654/* Given a type that corresponds to a renaming entity, use the type name
4655 to extract the scope (package name or function name, fully qualified,
4656 and following the GNAT encoding convention) where this renaming has been
4657 defined. The string returned needs to be deallocated after use. */
4c4b4cd2 4658
96d887e8
PH
4659static char *
4660xget_renaming_scope (struct type *renaming_type)
14f9c5c9 4661{
96d887e8 4662 /* The renaming types adhere to the following convention:
0963b4bd 4663 <scope>__<rename>___<XR extension>.
96d887e8
PH
4664 So, to extract the scope, we search for the "___XR" extension,
4665 and then backtrack until we find the first "__". */
76a01679 4666
96d887e8
PH
4667 const char *name = type_name_no_tag (renaming_type);
4668 char *suffix = strstr (name, "___XR");
4669 char *last;
4670 int scope_len;
4671 char *scope;
14f9c5c9 4672
96d887e8
PH
4673 /* Now, backtrack a bit until we find the first "__". Start looking
4674 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 4675
96d887e8
PH
4676 for (last = suffix - 3; last > name; last--)
4677 if (last[0] == '_' && last[1] == '_')
4678 break;
76a01679 4679
96d887e8 4680 /* Make a copy of scope and return it. */
14f9c5c9 4681
96d887e8
PH
4682 scope_len = last - name;
4683 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
14f9c5c9 4684
96d887e8
PH
4685 strncpy (scope, name, scope_len);
4686 scope[scope_len] = '\0';
4c4b4cd2 4687
96d887e8 4688 return scope;
4c4b4cd2
PH
4689}
4690
96d887e8 4691/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 4692
96d887e8
PH
4693static int
4694is_package_name (const char *name)
4c4b4cd2 4695{
96d887e8
PH
4696 /* Here, We take advantage of the fact that no symbols are generated
4697 for packages, while symbols are generated for each function.
4698 So the condition for NAME represent a package becomes equivalent
4699 to NAME not existing in our list of symbols. There is only one
4700 small complication with library-level functions (see below). */
4c4b4cd2 4701
96d887e8 4702 char *fun_name;
76a01679 4703
96d887e8
PH
4704 /* If it is a function that has not been defined at library level,
4705 then we should be able to look it up in the symbols. */
4706 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4707 return 0;
14f9c5c9 4708
96d887e8
PH
4709 /* Library-level function names start with "_ada_". See if function
4710 "_ada_" followed by NAME can be found. */
14f9c5c9 4711
96d887e8 4712 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 4713 functions names cannot contain "__" in them. */
96d887e8
PH
4714 if (strstr (name, "__") != NULL)
4715 return 0;
4c4b4cd2 4716
b435e160 4717 fun_name = xstrprintf ("_ada_%s", name);
14f9c5c9 4718
96d887e8
PH
4719 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4720}
14f9c5c9 4721
96d887e8 4722/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 4723 not visible from FUNCTION_NAME. */
14f9c5c9 4724
96d887e8 4725static int
0d5cff50 4726old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 4727{
aeb5907d 4728 char *scope;
1509e573 4729 struct cleanup *old_chain;
aeb5907d
JB
4730
4731 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4732 return 0;
4733
4734 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
1509e573 4735 old_chain = make_cleanup (xfree, scope);
14f9c5c9 4736
96d887e8
PH
4737 /* If the rename has been defined in a package, then it is visible. */
4738 if (is_package_name (scope))
1509e573
JB
4739 {
4740 do_cleanups (old_chain);
4741 return 0;
4742 }
14f9c5c9 4743
96d887e8
PH
4744 /* Check that the rename is in the current function scope by checking
4745 that its name starts with SCOPE. */
76a01679 4746
96d887e8
PH
4747 /* If the function name starts with "_ada_", it means that it is
4748 a library-level function. Strip this prefix before doing the
4749 comparison, as the encoding for the renaming does not contain
4750 this prefix. */
4751 if (strncmp (function_name, "_ada_", 5) == 0)
4752 function_name += 5;
f26caa11 4753
1509e573
JB
4754 {
4755 int is_invisible = strncmp (function_name, scope, strlen (scope)) != 0;
4756
4757 do_cleanups (old_chain);
4758 return is_invisible;
4759 }
f26caa11
PH
4760}
4761
aeb5907d
JB
4762/* Remove entries from SYMS that corresponds to a renaming entity that
4763 is not visible from the function associated with CURRENT_BLOCK or
4764 that is superfluous due to the presence of more specific renaming
4765 information. Places surviving symbols in the initial entries of
4766 SYMS and returns the number of surviving symbols.
96d887e8
PH
4767
4768 Rationale:
aeb5907d
JB
4769 First, in cases where an object renaming is implemented as a
4770 reference variable, GNAT may produce both the actual reference
4771 variable and the renaming encoding. In this case, we discard the
4772 latter.
4773
4774 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
4775 entity. Unfortunately, STABS currently does not support the definition
4776 of types that are local to a given lexical block, so all renamings types
4777 are emitted at library level. As a consequence, if an application
4778 contains two renaming entities using the same name, and a user tries to
4779 print the value of one of these entities, the result of the ada symbol
4780 lookup will also contain the wrong renaming type.
f26caa11 4781
96d887e8
PH
4782 This function partially covers for this limitation by attempting to
4783 remove from the SYMS list renaming symbols that should be visible
4784 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4785 method with the current information available. The implementation
4786 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4787
4788 - When the user tries to print a rename in a function while there
4789 is another rename entity defined in a package: Normally, the
4790 rename in the function has precedence over the rename in the
4791 package, so the latter should be removed from the list. This is
4792 currently not the case.
4793
4794 - This function will incorrectly remove valid renames if
4795 the CURRENT_BLOCK corresponds to a function which symbol name
4796 has been changed by an "Export" pragma. As a consequence,
4797 the user will be unable to print such rename entities. */
4c4b4cd2 4798
14f9c5c9 4799static int
aeb5907d
JB
4800remove_irrelevant_renamings (struct ada_symbol_info *syms,
4801 int nsyms, const struct block *current_block)
4c4b4cd2
PH
4802{
4803 struct symbol *current_function;
0d5cff50 4804 const char *current_function_name;
4c4b4cd2 4805 int i;
aeb5907d
JB
4806 int is_new_style_renaming;
4807
4808 /* If there is both a renaming foo___XR... encoded as a variable and
4809 a simple variable foo in the same block, discard the latter.
0963b4bd 4810 First, zero out such symbols, then compress. */
aeb5907d
JB
4811 is_new_style_renaming = 0;
4812 for (i = 0; i < nsyms; i += 1)
4813 {
4814 struct symbol *sym = syms[i].sym;
270140bd 4815 const struct block *block = syms[i].block;
aeb5907d
JB
4816 const char *name;
4817 const char *suffix;
4818
4819 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4820 continue;
4821 name = SYMBOL_LINKAGE_NAME (sym);
4822 suffix = strstr (name, "___XR");
4823
4824 if (suffix != NULL)
4825 {
4826 int name_len = suffix - name;
4827 int j;
5b4ee69b 4828
aeb5907d
JB
4829 is_new_style_renaming = 1;
4830 for (j = 0; j < nsyms; j += 1)
4831 if (i != j && syms[j].sym != NULL
4832 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
4833 name_len) == 0
4834 && block == syms[j].block)
4835 syms[j].sym = NULL;
4836 }
4837 }
4838 if (is_new_style_renaming)
4839 {
4840 int j, k;
4841
4842 for (j = k = 0; j < nsyms; j += 1)
4843 if (syms[j].sym != NULL)
4844 {
4845 syms[k] = syms[j];
4846 k += 1;
4847 }
4848 return k;
4849 }
4c4b4cd2
PH
4850
4851 /* Extract the function name associated to CURRENT_BLOCK.
4852 Abort if unable to do so. */
76a01679 4853
4c4b4cd2
PH
4854 if (current_block == NULL)
4855 return nsyms;
76a01679 4856
7f0df278 4857 current_function = block_linkage_function (current_block);
4c4b4cd2
PH
4858 if (current_function == NULL)
4859 return nsyms;
4860
4861 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
4862 if (current_function_name == NULL)
4863 return nsyms;
4864
4865 /* Check each of the symbols, and remove it from the list if it is
4866 a type corresponding to a renaming that is out of the scope of
4867 the current block. */
4868
4869 i = 0;
4870 while (i < nsyms)
4871 {
aeb5907d
JB
4872 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
4873 == ADA_OBJECT_RENAMING
4874 && old_renaming_is_invisible (syms[i].sym, current_function_name))
4c4b4cd2
PH
4875 {
4876 int j;
5b4ee69b 4877
aeb5907d 4878 for (j = i + 1; j < nsyms; j += 1)
76a01679 4879 syms[j - 1] = syms[j];
4c4b4cd2
PH
4880 nsyms -= 1;
4881 }
4882 else
4883 i += 1;
4884 }
4885
4886 return nsyms;
4887}
4888
339c13b6
JB
4889/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4890 whose name and domain match NAME and DOMAIN respectively.
4891 If no match was found, then extend the search to "enclosing"
4892 routines (in other words, if we're inside a nested function,
4893 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
4894 If WILD_MATCH_P is nonzero, perform the naming matching in
4895 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
4896
4897 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4898
4899static void
4900ada_add_local_symbols (struct obstack *obstackp, const char *name,
4901 struct block *block, domain_enum domain,
d0a8ab18 4902 int wild_match_p)
339c13b6
JB
4903{
4904 int block_depth = 0;
4905
4906 while (block != NULL)
4907 {
4908 block_depth += 1;
d0a8ab18
JB
4909 ada_add_block_symbols (obstackp, block, name, domain, NULL,
4910 wild_match_p);
339c13b6
JB
4911
4912 /* If we found a non-function match, assume that's the one. */
4913 if (is_nonfunction (defns_collected (obstackp, 0),
4914 num_defns_collected (obstackp)))
4915 return;
4916
4917 block = BLOCK_SUPERBLOCK (block);
4918 }
4919
4920 /* If no luck so far, try to find NAME as a local symbol in some lexically
4921 enclosing subprogram. */
4922 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
d0a8ab18 4923 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match_p);
339c13b6
JB
4924}
4925
ccefe4c4 4926/* An object of this type is used as the user_data argument when
40658b94 4927 calling the map_matching_symbols method. */
ccefe4c4 4928
40658b94 4929struct match_data
ccefe4c4 4930{
40658b94 4931 struct objfile *objfile;
ccefe4c4 4932 struct obstack *obstackp;
40658b94
PH
4933 struct symbol *arg_sym;
4934 int found_sym;
ccefe4c4
TT
4935};
4936
40658b94
PH
4937/* A callback for add_matching_symbols that adds SYM, found in BLOCK,
4938 to a list of symbols. DATA0 is a pointer to a struct match_data *
4939 containing the obstack that collects the symbol list, the file that SYM
4940 must come from, a flag indicating whether a non-argument symbol has
4941 been found in the current block, and the last argument symbol
4942 passed in SYM within the current block (if any). When SYM is null,
4943 marking the end of a block, the argument symbol is added if no
4944 other has been found. */
ccefe4c4 4945
40658b94
PH
4946static int
4947aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 4948{
40658b94
PH
4949 struct match_data *data = (struct match_data *) data0;
4950
4951 if (sym == NULL)
4952 {
4953 if (!data->found_sym && data->arg_sym != NULL)
4954 add_defn_to_vec (data->obstackp,
4955 fixup_symbol_section (data->arg_sym, data->objfile),
4956 block);
4957 data->found_sym = 0;
4958 data->arg_sym = NULL;
4959 }
4960 else
4961 {
4962 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
4963 return 0;
4964 else if (SYMBOL_IS_ARGUMENT (sym))
4965 data->arg_sym = sym;
4966 else
4967 {
4968 data->found_sym = 1;
4969 add_defn_to_vec (data->obstackp,
4970 fixup_symbol_section (sym, data->objfile),
4971 block);
4972 }
4973 }
4974 return 0;
4975}
4976
4977/* Compare STRING1 to STRING2, with results as for strcmp.
4978 Compatible with strcmp_iw in that strcmp_iw (STRING1, STRING2) <= 0
4979 implies compare_names (STRING1, STRING2) (they may differ as to
4980 what symbols compare equal). */
5b4ee69b 4981
40658b94
PH
4982static int
4983compare_names (const char *string1, const char *string2)
4984{
4985 while (*string1 != '\0' && *string2 != '\0')
4986 {
4987 if (isspace (*string1) || isspace (*string2))
4988 return strcmp_iw_ordered (string1, string2);
4989 if (*string1 != *string2)
4990 break;
4991 string1 += 1;
4992 string2 += 1;
4993 }
4994 switch (*string1)
4995 {
4996 case '(':
4997 return strcmp_iw_ordered (string1, string2);
4998 case '_':
4999 if (*string2 == '\0')
5000 {
052874e8 5001 if (is_name_suffix (string1))
40658b94
PH
5002 return 0;
5003 else
1a1d5513 5004 return 1;
40658b94 5005 }
dbb8534f 5006 /* FALLTHROUGH */
40658b94
PH
5007 default:
5008 if (*string2 == '(')
5009 return strcmp_iw_ordered (string1, string2);
5010 else
5011 return *string1 - *string2;
5012 }
ccefe4c4
TT
5013}
5014
339c13b6
JB
5015/* Add to OBSTACKP all non-local symbols whose name and domain match
5016 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
5017 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
5018
5019static void
40658b94
PH
5020add_nonlocal_symbols (struct obstack *obstackp, const char *name,
5021 domain_enum domain, int global,
5022 int is_wild_match)
339c13b6
JB
5023{
5024 struct objfile *objfile;
40658b94 5025 struct match_data data;
339c13b6 5026
6475f2fe 5027 memset (&data, 0, sizeof data);
ccefe4c4 5028 data.obstackp = obstackp;
339c13b6 5029
ccefe4c4 5030 ALL_OBJFILES (objfile)
40658b94
PH
5031 {
5032 data.objfile = objfile;
5033
5034 if (is_wild_match)
5035 objfile->sf->qf->map_matching_symbols (name, domain, objfile, global,
5036 aux_add_nonlocal_symbols, &data,
5037 wild_match, NULL);
5038 else
5039 objfile->sf->qf->map_matching_symbols (name, domain, objfile, global,
5040 aux_add_nonlocal_symbols, &data,
5041 full_match, compare_names);
5042 }
5043
5044 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5045 {
5046 ALL_OBJFILES (objfile)
5047 {
5048 char *name1 = alloca (strlen (name) + sizeof ("_ada_"));
5049 strcpy (name1, "_ada_");
5050 strcpy (name1 + sizeof ("_ada_") - 1, name);
5051 data.objfile = objfile;
0963b4bd
MS
5052 objfile->sf->qf->map_matching_symbols (name1, domain,
5053 objfile, global,
5054 aux_add_nonlocal_symbols,
5055 &data,
40658b94
PH
5056 full_match, compare_names);
5057 }
5058 }
339c13b6
JB
5059}
5060
4eeaa230
DE
5061/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and, if full_search is
5062 non-zero, enclosing scope and in global scopes, returning the number of
5063 matches.
9f88c959 5064 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4c4b4cd2 5065 indicating the symbols found and the blocks and symbol tables (if
4eeaa230
DE
5066 any) in which they were found. This vector is transient---good only to
5067 the next call of ada_lookup_symbol_list.
5068
5069 When full_search is non-zero, any non-function/non-enumeral
4c4b4cd2
PH
5070 symbol match within the nest of blocks whose innermost member is BLOCK0,
5071 is the one match returned (no other matches in that or
d9680e73 5072 enclosing blocks is returned). If there are any matches in or
4eeaa230
DE
5073 surrounding BLOCK0, then these alone are returned.
5074
9f88c959 5075 Names prefixed with "standard__" are handled specially: "standard__"
4c4b4cd2 5076 is first stripped off, and only static and global symbols are searched. */
14f9c5c9 5077
4eeaa230
DE
5078static int
5079ada_lookup_symbol_list_worker (const char *name0, const struct block *block0,
5080 domain_enum namespace,
5081 struct ada_symbol_info **results,
5082 int full_search)
14f9c5c9
AS
5083{
5084 struct symbol *sym;
14f9c5c9 5085 struct block *block;
4c4b4cd2 5086 const char *name;
82ccd55e 5087 const int wild_match_p = should_use_wild_match (name0);
14f9c5c9 5088 int cacheIfUnique;
4c4b4cd2 5089 int ndefns;
14f9c5c9 5090
4c4b4cd2
PH
5091 obstack_free (&symbol_list_obstack, NULL);
5092 obstack_init (&symbol_list_obstack);
14f9c5c9 5093
14f9c5c9
AS
5094 cacheIfUnique = 0;
5095
5096 /* Search specified block and its superiors. */
5097
4c4b4cd2 5098 name = name0;
76a01679
JB
5099 block = (struct block *) block0; /* FIXME: No cast ought to be
5100 needed, but adding const will
5101 have a cascade effect. */
339c13b6
JB
5102
5103 /* Special case: If the user specifies a symbol name inside package
5104 Standard, do a non-wild matching of the symbol name without
5105 the "standard__" prefix. This was primarily introduced in order
5106 to allow the user to specifically access the standard exceptions
5107 using, for instance, Standard.Constraint_Error when Constraint_Error
5108 is ambiguous (due to the user defining its own Constraint_Error
5109 entity inside its program). */
4c4b4cd2
PH
5110 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
5111 {
4c4b4cd2
PH
5112 block = NULL;
5113 name = name0 + sizeof ("standard__") - 1;
5114 }
5115
339c13b6 5116 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5117
4eeaa230
DE
5118 if (block != NULL)
5119 {
5120 if (full_search)
5121 {
5122 ada_add_local_symbols (&symbol_list_obstack, name, block,
5123 namespace, wild_match_p);
5124 }
5125 else
5126 {
5127 /* In the !full_search case we're are being called by
5128 ada_iterate_over_symbols, and we don't want to search
5129 superblocks. */
5130 ada_add_block_symbols (&symbol_list_obstack, block, name,
5131 namespace, NULL, wild_match_p);
5132 }
5133 if (num_defns_collected (&symbol_list_obstack) > 0 || !full_search)
5134 goto done;
5135 }
d2e4a39e 5136
339c13b6
JB
5137 /* No non-global symbols found. Check our cache to see if we have
5138 already performed this search before. If we have, then return
5139 the same result. */
5140
14f9c5c9 5141 cacheIfUnique = 1;
2570f2b7 5142 if (lookup_cached_symbol (name0, namespace, &sym, &block))
4c4b4cd2
PH
5143 {
5144 if (sym != NULL)
2570f2b7 5145 add_defn_to_vec (&symbol_list_obstack, sym, block);
4c4b4cd2
PH
5146 goto done;
5147 }
14f9c5c9 5148
339c13b6
JB
5149 /* Search symbols from all global blocks. */
5150
40658b94 5151 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 1,
82ccd55e 5152 wild_match_p);
d2e4a39e 5153
4c4b4cd2 5154 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5155 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5156
4c4b4cd2 5157 if (num_defns_collected (&symbol_list_obstack) == 0)
40658b94 5158 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 0,
82ccd55e 5159 wild_match_p);
14f9c5c9 5160
4c4b4cd2
PH
5161done:
5162 ndefns = num_defns_collected (&symbol_list_obstack);
5163 *results = defns_collected (&symbol_list_obstack, 1);
5164
5165 ndefns = remove_extra_symbols (*results, ndefns);
5166
2ad01556 5167 if (ndefns == 0 && full_search)
2570f2b7 5168 cache_symbol (name0, namespace, NULL, NULL);
14f9c5c9 5169
2ad01556 5170 if (ndefns == 1 && full_search && cacheIfUnique)
2570f2b7 5171 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
14f9c5c9 5172
aeb5907d 5173 ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
14f9c5c9 5174
14f9c5c9
AS
5175 return ndefns;
5176}
5177
4eeaa230
DE
5178/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and
5179 in global scopes, returning the number of matches, and setting *RESULTS
5180 to a vector of (SYM,BLOCK) tuples.
5181 See ada_lookup_symbol_list_worker for further details. */
5182
5183int
5184ada_lookup_symbol_list (const char *name0, const struct block *block0,
5185 domain_enum domain, struct ada_symbol_info **results)
5186{
5187 return ada_lookup_symbol_list_worker (name0, block0, domain, results, 1);
5188}
5189
5190/* Implementation of the la_iterate_over_symbols method. */
5191
5192static void
5193ada_iterate_over_symbols (const struct block *block,
5194 const char *name, domain_enum domain,
5195 symbol_found_callback_ftype *callback,
5196 void *data)
5197{
5198 int ndefs, i;
5199 struct ada_symbol_info *results;
5200
5201 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5202 for (i = 0; i < ndefs; ++i)
5203 {
5204 if (! (*callback) (results[i].sym, data))
5205 break;
5206 }
5207}
5208
f8eba3c6
TT
5209/* If NAME is the name of an entity, return a string that should
5210 be used to look that entity up in Ada units. This string should
5211 be deallocated after use using xfree.
5212
5213 NAME can have any form that the "break" or "print" commands might
5214 recognize. In other words, it does not have to be the "natural"
5215 name, or the "encoded" name. */
5216
5217char *
5218ada_name_for_lookup (const char *name)
5219{
5220 char *canon;
5221 int nlen = strlen (name);
5222
5223 if (name[0] == '<' && name[nlen - 1] == '>')
5224 {
5225 canon = xmalloc (nlen - 1);
5226 memcpy (canon, name + 1, nlen - 2);
5227 canon[nlen - 2] = '\0';
5228 }
5229 else
5230 canon = xstrdup (ada_encode (ada_fold_name (name)));
5231 return canon;
5232}
5233
4e5c77fe
JB
5234/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5235 to 1, but choosing the first symbol found if there are multiple
5236 choices.
5237
5e2336be
JB
5238 The result is stored in *INFO, which must be non-NULL.
5239 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5240
5241void
5242ada_lookup_encoded_symbol (const char *name, const struct block *block,
5243 domain_enum namespace,
5e2336be 5244 struct ada_symbol_info *info)
14f9c5c9 5245{
4c4b4cd2 5246 struct ada_symbol_info *candidates;
14f9c5c9
AS
5247 int n_candidates;
5248
5e2336be
JB
5249 gdb_assert (info != NULL);
5250 memset (info, 0, sizeof (struct ada_symbol_info));
4e5c77fe 5251
4eeaa230 5252 n_candidates = ada_lookup_symbol_list (name, block, namespace, &candidates);
14f9c5c9 5253 if (n_candidates == 0)
4e5c77fe 5254 return;
4c4b4cd2 5255
5e2336be
JB
5256 *info = candidates[0];
5257 info->sym = fixup_symbol_section (info->sym, NULL);
4e5c77fe 5258}
aeb5907d
JB
5259
5260/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5261 scope and in global scopes, or NULL if none. NAME is folded and
5262 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5263 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5264 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5265
aeb5907d
JB
5266struct symbol *
5267ada_lookup_symbol (const char *name, const struct block *block0,
21b556f4 5268 domain_enum namespace, int *is_a_field_of_this)
aeb5907d 5269{
5e2336be 5270 struct ada_symbol_info info;
4e5c77fe 5271
aeb5907d
JB
5272 if (is_a_field_of_this != NULL)
5273 *is_a_field_of_this = 0;
5274
4e5c77fe 5275 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
5e2336be
JB
5276 block0, namespace, &info);
5277 return info.sym;
4c4b4cd2 5278}
14f9c5c9 5279
4c4b4cd2
PH
5280static struct symbol *
5281ada_lookup_symbol_nonlocal (const char *name,
76a01679 5282 const struct block *block,
21b556f4 5283 const domain_enum domain)
4c4b4cd2 5284{
94af9270 5285 return ada_lookup_symbol (name, block_static_block (block), domain, NULL);
14f9c5c9
AS
5286}
5287
5288
4c4b4cd2
PH
5289/* True iff STR is a possible encoded suffix of a normal Ada name
5290 that is to be ignored for matching purposes. Suffixes of parallel
5291 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5292 are given by any of the regular expressions:
4c4b4cd2 5293
babe1480
JB
5294 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5295 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5296 TKB [subprogram suffix for task bodies]
babe1480 5297 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5298 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5299
5300 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5301 match is performed. This sequence is used to differentiate homonyms,
5302 is an optional part of a valid name suffix. */
4c4b4cd2 5303
14f9c5c9 5304static int
d2e4a39e 5305is_name_suffix (const char *str)
14f9c5c9
AS
5306{
5307 int k;
4c4b4cd2
PH
5308 const char *matching;
5309 const int len = strlen (str);
5310
babe1480
JB
5311 /* Skip optional leading __[0-9]+. */
5312
4c4b4cd2
PH
5313 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5314 {
babe1480
JB
5315 str += 3;
5316 while (isdigit (str[0]))
5317 str += 1;
4c4b4cd2 5318 }
babe1480
JB
5319
5320 /* [.$][0-9]+ */
4c4b4cd2 5321
babe1480 5322 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5323 {
babe1480 5324 matching = str + 1;
4c4b4cd2
PH
5325 while (isdigit (matching[0]))
5326 matching += 1;
5327 if (matching[0] == '\0')
5328 return 1;
5329 }
5330
5331 /* ___[0-9]+ */
babe1480 5332
4c4b4cd2
PH
5333 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5334 {
5335 matching = str + 3;
5336 while (isdigit (matching[0]))
5337 matching += 1;
5338 if (matching[0] == '\0')
5339 return 1;
5340 }
5341
9ac7f98e
JB
5342 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5343
5344 if (strcmp (str, "TKB") == 0)
5345 return 1;
5346
529cad9c
PH
5347#if 0
5348 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
5349 with a N at the end. Unfortunately, the compiler uses the same
5350 convention for other internal types it creates. So treating
529cad9c 5351 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
5352 some regressions. For instance, consider the case of an enumerated
5353 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
5354 name ends with N.
5355 Having a single character like this as a suffix carrying some
0963b4bd 5356 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
5357 to be something like "_N" instead. In the meantime, do not do
5358 the following check. */
5359 /* Protected Object Subprograms */
5360 if (len == 1 && str [0] == 'N')
5361 return 1;
5362#endif
5363
5364 /* _E[0-9]+[bs]$ */
5365 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5366 {
5367 matching = str + 3;
5368 while (isdigit (matching[0]))
5369 matching += 1;
5370 if ((matching[0] == 'b' || matching[0] == 's')
5371 && matching [1] == '\0')
5372 return 1;
5373 }
5374
4c4b4cd2
PH
5375 /* ??? We should not modify STR directly, as we are doing below. This
5376 is fine in this case, but may become problematic later if we find
5377 that this alternative did not work, and want to try matching
5378 another one from the begining of STR. Since we modified it, we
5379 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
5380 if (str[0] == 'X')
5381 {
5382 str += 1;
d2e4a39e 5383 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
5384 {
5385 if (str[0] != 'n' && str[0] != 'b')
5386 return 0;
5387 str += 1;
5388 }
14f9c5c9 5389 }
babe1480 5390
14f9c5c9
AS
5391 if (str[0] == '\000')
5392 return 1;
babe1480 5393
d2e4a39e 5394 if (str[0] == '_')
14f9c5c9
AS
5395 {
5396 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 5397 return 0;
d2e4a39e 5398 if (str[2] == '_')
4c4b4cd2 5399 {
61ee279c
PH
5400 if (strcmp (str + 3, "JM") == 0)
5401 return 1;
5402 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5403 the LJM suffix in favor of the JM one. But we will
5404 still accept LJM as a valid suffix for a reasonable
5405 amount of time, just to allow ourselves to debug programs
5406 compiled using an older version of GNAT. */
4c4b4cd2
PH
5407 if (strcmp (str + 3, "LJM") == 0)
5408 return 1;
5409 if (str[3] != 'X')
5410 return 0;
1265e4aa
JB
5411 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5412 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
5413 return 1;
5414 if (str[4] == 'R' && str[5] != 'T')
5415 return 1;
5416 return 0;
5417 }
5418 if (!isdigit (str[2]))
5419 return 0;
5420 for (k = 3; str[k] != '\0'; k += 1)
5421 if (!isdigit (str[k]) && str[k] != '_')
5422 return 0;
14f9c5c9
AS
5423 return 1;
5424 }
4c4b4cd2 5425 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 5426 {
4c4b4cd2
PH
5427 for (k = 2; str[k] != '\0'; k += 1)
5428 if (!isdigit (str[k]) && str[k] != '_')
5429 return 0;
14f9c5c9
AS
5430 return 1;
5431 }
5432 return 0;
5433}
d2e4a39e 5434
aeb5907d
JB
5435/* Return non-zero if the string starting at NAME and ending before
5436 NAME_END contains no capital letters. */
529cad9c
PH
5437
5438static int
5439is_valid_name_for_wild_match (const char *name0)
5440{
5441 const char *decoded_name = ada_decode (name0);
5442 int i;
5443
5823c3ef
JB
5444 /* If the decoded name starts with an angle bracket, it means that
5445 NAME0 does not follow the GNAT encoding format. It should then
5446 not be allowed as a possible wild match. */
5447 if (decoded_name[0] == '<')
5448 return 0;
5449
529cad9c
PH
5450 for (i=0; decoded_name[i] != '\0'; i++)
5451 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5452 return 0;
5453
5454 return 1;
5455}
5456
73589123
PH
5457/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5458 that could start a simple name. Assumes that *NAMEP points into
5459 the string beginning at NAME0. */
4c4b4cd2 5460
14f9c5c9 5461static int
73589123 5462advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 5463{
73589123 5464 const char *name = *namep;
5b4ee69b 5465
5823c3ef 5466 while (1)
14f9c5c9 5467 {
aa27d0b3 5468 int t0, t1;
73589123
PH
5469
5470 t0 = *name;
5471 if (t0 == '_')
5472 {
5473 t1 = name[1];
5474 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5475 {
5476 name += 1;
5477 if (name == name0 + 5 && strncmp (name0, "_ada", 4) == 0)
5478 break;
5479 else
5480 name += 1;
5481 }
aa27d0b3
JB
5482 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5483 || name[2] == target0))
73589123
PH
5484 {
5485 name += 2;
5486 break;
5487 }
5488 else
5489 return 0;
5490 }
5491 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5492 name += 1;
5493 else
5823c3ef 5494 return 0;
73589123
PH
5495 }
5496
5497 *namep = name;
5498 return 1;
5499}
5500
5501/* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5502 informational suffixes of NAME (i.e., for which is_name_suffix is
5503 true). Assumes that PATN is a lower-cased Ada simple name. */
5504
5505static int
5506wild_match (const char *name, const char *patn)
5507{
22e048c9 5508 const char *p;
73589123
PH
5509 const char *name0 = name;
5510
5511 while (1)
5512 {
5513 const char *match = name;
5514
5515 if (*name == *patn)
5516 {
5517 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5518 if (*p != *name)
5519 break;
5520 if (*p == '\0' && is_name_suffix (name))
5521 return match != name0 && !is_valid_name_for_wild_match (name0);
5522
5523 if (name[-1] == '_')
5524 name -= 1;
5525 }
5526 if (!advance_wild_match (&name, name0, *patn))
5527 return 1;
96d887e8 5528 }
96d887e8
PH
5529}
5530
40658b94
PH
5531/* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
5532 informational suffix. */
5533
c4d840bd
PH
5534static int
5535full_match (const char *sym_name, const char *search_name)
5536{
40658b94 5537 return !match_name (sym_name, search_name, 0);
c4d840bd
PH
5538}
5539
5540
96d887e8
PH
5541/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5542 vector *defn_symbols, updating the list of symbols in OBSTACKP
0963b4bd 5543 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4eeaa230 5544 OBJFILE is the section containing BLOCK. */
96d887e8
PH
5545
5546static void
5547ada_add_block_symbols (struct obstack *obstackp,
76a01679 5548 struct block *block, const char *name,
96d887e8 5549 domain_enum domain, struct objfile *objfile,
2570f2b7 5550 int wild)
96d887e8 5551{
8157b174 5552 struct block_iterator iter;
96d887e8
PH
5553 int name_len = strlen (name);
5554 /* A matching argument symbol, if any. */
5555 struct symbol *arg_sym;
5556 /* Set true when we find a matching non-argument symbol. */
5557 int found_sym;
5558 struct symbol *sym;
5559
5560 arg_sym = NULL;
5561 found_sym = 0;
5562 if (wild)
5563 {
8157b174
TT
5564 for (sym = block_iter_match_first (block, name, wild_match, &iter);
5565 sym != NULL; sym = block_iter_match_next (name, wild_match, &iter))
76a01679 5566 {
5eeb2539
AR
5567 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5568 SYMBOL_DOMAIN (sym), domain)
73589123 5569 && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0)
76a01679 5570 {
2a2d4dc3
AS
5571 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5572 continue;
5573 else if (SYMBOL_IS_ARGUMENT (sym))
5574 arg_sym = sym;
5575 else
5576 {
76a01679
JB
5577 found_sym = 1;
5578 add_defn_to_vec (obstackp,
5579 fixup_symbol_section (sym, objfile),
2570f2b7 5580 block);
76a01679
JB
5581 }
5582 }
5583 }
96d887e8
PH
5584 }
5585 else
5586 {
8157b174
TT
5587 for (sym = block_iter_match_first (block, name, full_match, &iter);
5588 sym != NULL; sym = block_iter_match_next (name, full_match, &iter))
76a01679 5589 {
5eeb2539
AR
5590 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5591 SYMBOL_DOMAIN (sym), domain))
76a01679 5592 {
c4d840bd
PH
5593 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5594 {
5595 if (SYMBOL_IS_ARGUMENT (sym))
5596 arg_sym = sym;
5597 else
2a2d4dc3 5598 {
c4d840bd
PH
5599 found_sym = 1;
5600 add_defn_to_vec (obstackp,
5601 fixup_symbol_section (sym, objfile),
5602 block);
2a2d4dc3 5603 }
c4d840bd 5604 }
76a01679
JB
5605 }
5606 }
96d887e8
PH
5607 }
5608
5609 if (!found_sym && arg_sym != NULL)
5610 {
76a01679
JB
5611 add_defn_to_vec (obstackp,
5612 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5613 block);
96d887e8
PH
5614 }
5615
5616 if (!wild)
5617 {
5618 arg_sym = NULL;
5619 found_sym = 0;
5620
5621 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 5622 {
5eeb2539
AR
5623 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5624 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
5625 {
5626 int cmp;
5627
5628 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5629 if (cmp == 0)
5630 {
5631 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5632 if (cmp == 0)
5633 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5634 name_len);
5635 }
5636
5637 if (cmp == 0
5638 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5639 {
2a2d4dc3
AS
5640 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5641 {
5642 if (SYMBOL_IS_ARGUMENT (sym))
5643 arg_sym = sym;
5644 else
5645 {
5646 found_sym = 1;
5647 add_defn_to_vec (obstackp,
5648 fixup_symbol_section (sym, objfile),
5649 block);
5650 }
5651 }
76a01679
JB
5652 }
5653 }
76a01679 5654 }
96d887e8
PH
5655
5656 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5657 They aren't parameters, right? */
5658 if (!found_sym && arg_sym != NULL)
5659 {
5660 add_defn_to_vec (obstackp,
76a01679 5661 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5662 block);
96d887e8
PH
5663 }
5664 }
5665}
5666\f
41d27058
JB
5667
5668 /* Symbol Completion */
5669
5670/* If SYM_NAME is a completion candidate for TEXT, return this symbol
5671 name in a form that's appropriate for the completion. The result
5672 does not need to be deallocated, but is only good until the next call.
5673
5674 TEXT_LEN is equal to the length of TEXT.
e701b3c0 5675 Perform a wild match if WILD_MATCH_P is set.
6ea35997 5676 ENCODED_P should be set if TEXT represents the start of a symbol name
41d27058
JB
5677 in its encoded form. */
5678
5679static const char *
5680symbol_completion_match (const char *sym_name,
5681 const char *text, int text_len,
6ea35997 5682 int wild_match_p, int encoded_p)
41d27058 5683{
41d27058
JB
5684 const int verbatim_match = (text[0] == '<');
5685 int match = 0;
5686
5687 if (verbatim_match)
5688 {
5689 /* Strip the leading angle bracket. */
5690 text = text + 1;
5691 text_len--;
5692 }
5693
5694 /* First, test against the fully qualified name of the symbol. */
5695
5696 if (strncmp (sym_name, text, text_len) == 0)
5697 match = 1;
5698
6ea35997 5699 if (match && !encoded_p)
41d27058
JB
5700 {
5701 /* One needed check before declaring a positive match is to verify
5702 that iff we are doing a verbatim match, the decoded version
5703 of the symbol name starts with '<'. Otherwise, this symbol name
5704 is not a suitable completion. */
5705 const char *sym_name_copy = sym_name;
5706 int has_angle_bracket;
5707
5708 sym_name = ada_decode (sym_name);
5709 has_angle_bracket = (sym_name[0] == '<');
5710 match = (has_angle_bracket == verbatim_match);
5711 sym_name = sym_name_copy;
5712 }
5713
5714 if (match && !verbatim_match)
5715 {
5716 /* When doing non-verbatim match, another check that needs to
5717 be done is to verify that the potentially matching symbol name
5718 does not include capital letters, because the ada-mode would
5719 not be able to understand these symbol names without the
5720 angle bracket notation. */
5721 const char *tmp;
5722
5723 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5724 if (*tmp != '\0')
5725 match = 0;
5726 }
5727
5728 /* Second: Try wild matching... */
5729
e701b3c0 5730 if (!match && wild_match_p)
41d27058
JB
5731 {
5732 /* Since we are doing wild matching, this means that TEXT
5733 may represent an unqualified symbol name. We therefore must
5734 also compare TEXT against the unqualified name of the symbol. */
5735 sym_name = ada_unqualified_name (ada_decode (sym_name));
5736
5737 if (strncmp (sym_name, text, text_len) == 0)
5738 match = 1;
5739 }
5740
5741 /* Finally: If we found a mach, prepare the result to return. */
5742
5743 if (!match)
5744 return NULL;
5745
5746 if (verbatim_match)
5747 sym_name = add_angle_brackets (sym_name);
5748
6ea35997 5749 if (!encoded_p)
41d27058
JB
5750 sym_name = ada_decode (sym_name);
5751
5752 return sym_name;
5753}
5754
5755/* A companion function to ada_make_symbol_completion_list().
5756 Check if SYM_NAME represents a symbol which name would be suitable
5757 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5758 it is appended at the end of the given string vector SV.
5759
5760 ORIG_TEXT is the string original string from the user command
5761 that needs to be completed. WORD is the entire command on which
5762 completion should be performed. These two parameters are used to
5763 determine which part of the symbol name should be added to the
5764 completion vector.
c0af1706 5765 if WILD_MATCH_P is set, then wild matching is performed.
cb8e9b97 5766 ENCODED_P should be set if TEXT represents a symbol name in its
41d27058
JB
5767 encoded formed (in which case the completion should also be
5768 encoded). */
5769
5770static void
d6565258 5771symbol_completion_add (VEC(char_ptr) **sv,
41d27058
JB
5772 const char *sym_name,
5773 const char *text, int text_len,
5774 const char *orig_text, const char *word,
cb8e9b97 5775 int wild_match_p, int encoded_p)
41d27058
JB
5776{
5777 const char *match = symbol_completion_match (sym_name, text, text_len,
cb8e9b97 5778 wild_match_p, encoded_p);
41d27058
JB
5779 char *completion;
5780
5781 if (match == NULL)
5782 return;
5783
5784 /* We found a match, so add the appropriate completion to the given
5785 string vector. */
5786
5787 if (word == orig_text)
5788 {
5789 completion = xmalloc (strlen (match) + 5);
5790 strcpy (completion, match);
5791 }
5792 else if (word > orig_text)
5793 {
5794 /* Return some portion of sym_name. */
5795 completion = xmalloc (strlen (match) + 5);
5796 strcpy (completion, match + (word - orig_text));
5797 }
5798 else
5799 {
5800 /* Return some of ORIG_TEXT plus sym_name. */
5801 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
5802 strncpy (completion, word, orig_text - word);
5803 completion[orig_text - word] = '\0';
5804 strcat (completion, match);
5805 }
5806
d6565258 5807 VEC_safe_push (char_ptr, *sv, completion);
41d27058
JB
5808}
5809
ccefe4c4 5810/* An object of this type is passed as the user_data argument to the
7b08b9eb 5811 expand_partial_symbol_names method. */
ccefe4c4
TT
5812struct add_partial_datum
5813{
5814 VEC(char_ptr) **completions;
6f937416 5815 const char *text;
ccefe4c4 5816 int text_len;
6f937416
PA
5817 const char *text0;
5818 const char *word;
ccefe4c4
TT
5819 int wild_match;
5820 int encoded;
5821};
5822
7b08b9eb
JK
5823/* A callback for expand_partial_symbol_names. */
5824static int
e078317b 5825ada_expand_partial_symbol_name (const char *name, void *user_data)
ccefe4c4
TT
5826{
5827 struct add_partial_datum *data = user_data;
7b08b9eb
JK
5828
5829 return symbol_completion_match (name, data->text, data->text_len,
5830 data->wild_match, data->encoded) != NULL;
ccefe4c4
TT
5831}
5832
49c4e619
TT
5833/* Return a list of possible symbol names completing TEXT0. WORD is
5834 the entire command on which completion is made. */
41d27058 5835
49c4e619 5836static VEC (char_ptr) *
6f937416
PA
5837ada_make_symbol_completion_list (const char *text0, const char *word,
5838 enum type_code code)
41d27058
JB
5839{
5840 char *text;
5841 int text_len;
b1ed564a
JB
5842 int wild_match_p;
5843 int encoded_p;
2ba95b9b 5844 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
41d27058
JB
5845 struct symbol *sym;
5846 struct symtab *s;
41d27058
JB
5847 struct minimal_symbol *msymbol;
5848 struct objfile *objfile;
5849 struct block *b, *surrounding_static_block = 0;
5850 int i;
8157b174 5851 struct block_iterator iter;
b8fea896 5852 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
41d27058 5853
2f68a895
TT
5854 gdb_assert (code == TYPE_CODE_UNDEF);
5855
41d27058
JB
5856 if (text0[0] == '<')
5857 {
5858 text = xstrdup (text0);
5859 make_cleanup (xfree, text);
5860 text_len = strlen (text);
b1ed564a
JB
5861 wild_match_p = 0;
5862 encoded_p = 1;
41d27058
JB
5863 }
5864 else
5865 {
5866 text = xstrdup (ada_encode (text0));
5867 make_cleanup (xfree, text);
5868 text_len = strlen (text);
5869 for (i = 0; i < text_len; i++)
5870 text[i] = tolower (text[i]);
5871
b1ed564a 5872 encoded_p = (strstr (text0, "__") != NULL);
41d27058
JB
5873 /* If the name contains a ".", then the user is entering a fully
5874 qualified entity name, and the match must not be done in wild
5875 mode. Similarly, if the user wants to complete what looks like
5876 an encoded name, the match must not be done in wild mode. */
b1ed564a 5877 wild_match_p = (strchr (text0, '.') == NULL && !encoded_p);
41d27058
JB
5878 }
5879
5880 /* First, look at the partial symtab symbols. */
41d27058 5881 {
ccefe4c4
TT
5882 struct add_partial_datum data;
5883
5884 data.completions = &completions;
5885 data.text = text;
5886 data.text_len = text_len;
5887 data.text0 = text0;
5888 data.word = word;
b1ed564a
JB
5889 data.wild_match = wild_match_p;
5890 data.encoded = encoded_p;
7b08b9eb 5891 expand_partial_symbol_names (ada_expand_partial_symbol_name, &data);
41d27058
JB
5892 }
5893
5894 /* At this point scan through the misc symbol vectors and add each
5895 symbol you find to the list. Eventually we want to ignore
5896 anything that isn't a text symbol (everything else will be
5897 handled by the psymtab code above). */
5898
5899 ALL_MSYMBOLS (objfile, msymbol)
5900 {
5901 QUIT;
d6565258 5902 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol),
b1ed564a
JB
5903 text, text_len, text0, word, wild_match_p,
5904 encoded_p);
41d27058
JB
5905 }
5906
5907 /* Search upwards from currently selected frame (so that we can
5908 complete on local vars. */
5909
5910 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
5911 {
5912 if (!BLOCK_SUPERBLOCK (b))
5913 surrounding_static_block = b; /* For elmin of dups */
5914
5915 ALL_BLOCK_SYMBOLS (b, iter, sym)
5916 {
d6565258 5917 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 5918 text, text_len, text0, word,
b1ed564a 5919 wild_match_p, encoded_p);
41d27058
JB
5920 }
5921 }
5922
5923 /* Go through the symtabs and check the externs and statics for
5924 symbols which match. */
5925
5926 ALL_SYMTABS (objfile, s)
5927 {
5928 QUIT;
5929 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
5930 ALL_BLOCK_SYMBOLS (b, iter, sym)
5931 {
d6565258 5932 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 5933 text, text_len, text0, word,
b1ed564a 5934 wild_match_p, encoded_p);
41d27058
JB
5935 }
5936 }
5937
5938 ALL_SYMTABS (objfile, s)
5939 {
5940 QUIT;
5941 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
5942 /* Don't do this block twice. */
5943 if (b == surrounding_static_block)
5944 continue;
5945 ALL_BLOCK_SYMBOLS (b, iter, sym)
5946 {
d6565258 5947 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 5948 text, text_len, text0, word,
b1ed564a 5949 wild_match_p, encoded_p);
41d27058
JB
5950 }
5951 }
5952
b8fea896 5953 do_cleanups (old_chain);
49c4e619 5954 return completions;
41d27058
JB
5955}
5956
963a6417 5957 /* Field Access */
96d887e8 5958
73fb9985
JB
5959/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5960 for tagged types. */
5961
5962static int
5963ada_is_dispatch_table_ptr_type (struct type *type)
5964{
0d5cff50 5965 const char *name;
73fb9985
JB
5966
5967 if (TYPE_CODE (type) != TYPE_CODE_PTR)
5968 return 0;
5969
5970 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
5971 if (name == NULL)
5972 return 0;
5973
5974 return (strcmp (name, "ada__tags__dispatch_table") == 0);
5975}
5976
ac4a2da4
JG
5977/* Return non-zero if TYPE is an interface tag. */
5978
5979static int
5980ada_is_interface_tag (struct type *type)
5981{
5982 const char *name = TYPE_NAME (type);
5983
5984 if (name == NULL)
5985 return 0;
5986
5987 return (strcmp (name, "ada__tags__interface_tag") == 0);
5988}
5989
963a6417
PH
5990/* True if field number FIELD_NUM in struct or union type TYPE is supposed
5991 to be invisible to users. */
96d887e8 5992
963a6417
PH
5993int
5994ada_is_ignored_field (struct type *type, int field_num)
96d887e8 5995{
963a6417
PH
5996 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
5997 return 1;
ffde82bf 5998
73fb9985
JB
5999 /* Check the name of that field. */
6000 {
6001 const char *name = TYPE_FIELD_NAME (type, field_num);
6002
6003 /* Anonymous field names should not be printed.
6004 brobecker/2007-02-20: I don't think this can actually happen
6005 but we don't want to print the value of annonymous fields anyway. */
6006 if (name == NULL)
6007 return 1;
6008
ffde82bf
JB
6009 /* Normally, fields whose name start with an underscore ("_")
6010 are fields that have been internally generated by the compiler,
6011 and thus should not be printed. The "_parent" field is special,
6012 however: This is a field internally generated by the compiler
6013 for tagged types, and it contains the components inherited from
6014 the parent type. This field should not be printed as is, but
6015 should not be ignored either. */
73fb9985
JB
6016 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
6017 return 1;
6018 }
6019
ac4a2da4
JG
6020 /* If this is the dispatch table of a tagged type or an interface tag,
6021 then ignore. */
73fb9985 6022 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6023 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6024 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6025 return 1;
6026
6027 /* Not a special field, so it should not be ignored. */
6028 return 0;
963a6417 6029}
96d887e8 6030
963a6417 6031/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6032 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6033
963a6417
PH
6034int
6035ada_is_tagged_type (struct type *type, int refok)
6036{
6037 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
6038}
96d887e8 6039
963a6417 6040/* True iff TYPE represents the type of X'Tag */
96d887e8 6041
963a6417
PH
6042int
6043ada_is_tag_type (struct type *type)
6044{
6045 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6046 return 0;
6047 else
96d887e8 6048 {
963a6417 6049 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6050
963a6417
PH
6051 return (name != NULL
6052 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6053 }
96d887e8
PH
6054}
6055
963a6417 6056/* The type of the tag on VAL. */
76a01679 6057
963a6417
PH
6058struct type *
6059ada_tag_type (struct value *val)
96d887e8 6060{
df407dfe 6061 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
963a6417 6062}
96d887e8 6063
b50d69b5
JG
6064/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6065 retired at Ada 05). */
6066
6067static int
6068is_ada95_tag (struct value *tag)
6069{
6070 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6071}
6072
963a6417 6073/* The value of the tag on VAL. */
96d887e8 6074
963a6417
PH
6075struct value *
6076ada_value_tag (struct value *val)
6077{
03ee6b2e 6078 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6079}
6080
963a6417
PH
6081/* The value of the tag on the object of type TYPE whose contents are
6082 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6083 ADDRESS. */
96d887e8 6084
963a6417 6085static struct value *
10a2c479 6086value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6087 const gdb_byte *valaddr,
963a6417 6088 CORE_ADDR address)
96d887e8 6089{
b5385fc0 6090 int tag_byte_offset;
963a6417 6091 struct type *tag_type;
5b4ee69b 6092
963a6417 6093 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6094 NULL, NULL, NULL))
96d887e8 6095 {
fc1a4b47 6096 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6097 ? NULL
6098 : valaddr + tag_byte_offset);
963a6417 6099 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6100
963a6417 6101 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6102 }
963a6417
PH
6103 return NULL;
6104}
96d887e8 6105
963a6417
PH
6106static struct type *
6107type_from_tag (struct value *tag)
6108{
6109 const char *type_name = ada_tag_name (tag);
5b4ee69b 6110
963a6417
PH
6111 if (type_name != NULL)
6112 return ada_find_any_type (ada_encode (type_name));
6113 return NULL;
6114}
96d887e8 6115
b50d69b5
JG
6116/* Given a value OBJ of a tagged type, return a value of this
6117 type at the base address of the object. The base address, as
6118 defined in Ada.Tags, it is the address of the primary tag of
6119 the object, and therefore where the field values of its full
6120 view can be fetched. */
6121
6122struct value *
6123ada_tag_value_at_base_address (struct value *obj)
6124{
6125 volatile struct gdb_exception e;
6126 struct value *val;
6127 LONGEST offset_to_top = 0;
6128 struct type *ptr_type, *obj_type;
6129 struct value *tag;
6130 CORE_ADDR base_address;
6131
6132 obj_type = value_type (obj);
6133
6134 /* It is the responsability of the caller to deref pointers. */
6135
6136 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6137 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6138 return obj;
6139
6140 tag = ada_value_tag (obj);
6141 if (!tag)
6142 return obj;
6143
6144 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6145
6146 if (is_ada95_tag (tag))
6147 return obj;
6148
6149 ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
6150 ptr_type = lookup_pointer_type (ptr_type);
6151 val = value_cast (ptr_type, tag);
6152 if (!val)
6153 return obj;
6154
6155 /* It is perfectly possible that an exception be raised while
6156 trying to determine the base address, just like for the tag;
6157 see ada_tag_name for more details. We do not print the error
6158 message for the same reason. */
6159
6160 TRY_CATCH (e, RETURN_MASK_ERROR)
6161 {
6162 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6163 }
6164
6165 if (e.reason < 0)
6166 return obj;
6167
6168 /* If offset is null, nothing to do. */
6169
6170 if (offset_to_top == 0)
6171 return obj;
6172
6173 /* -1 is a special case in Ada.Tags; however, what should be done
6174 is not quite clear from the documentation. So do nothing for
6175 now. */
6176
6177 if (offset_to_top == -1)
6178 return obj;
6179
6180 base_address = value_address (obj) - offset_to_top;
6181 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6182
6183 /* Make sure that we have a proper tag at the new address.
6184 Otherwise, offset_to_top is bogus (which can happen when
6185 the object is not initialized yet). */
6186
6187 if (!tag)
6188 return obj;
6189
6190 obj_type = type_from_tag (tag);
6191
6192 if (!obj_type)
6193 return obj;
6194
6195 return value_from_contents_and_address (obj_type, NULL, base_address);
6196}
6197
1b611343
JB
6198/* Return the "ada__tags__type_specific_data" type. */
6199
6200static struct type *
6201ada_get_tsd_type (struct inferior *inf)
963a6417 6202{
1b611343 6203 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6204
1b611343
JB
6205 if (data->tsd_type == 0)
6206 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6207 return data->tsd_type;
6208}
529cad9c 6209
1b611343
JB
6210/* Return the TSD (type-specific data) associated to the given TAG.
6211 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6212
1b611343 6213 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6214
1b611343
JB
6215static struct value *
6216ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6217{
4c4b4cd2 6218 struct value *val;
1b611343 6219 struct type *type;
5b4ee69b 6220
1b611343
JB
6221 /* First option: The TSD is simply stored as a field of our TAG.
6222 Only older versions of GNAT would use this format, but we have
6223 to test it first, because there are no visible markers for
6224 the current approach except the absence of that field. */
529cad9c 6225
1b611343
JB
6226 val = ada_value_struct_elt (tag, "tsd", 1);
6227 if (val)
6228 return val;
e802dbe0 6229
1b611343
JB
6230 /* Try the second representation for the dispatch table (in which
6231 there is no explicit 'tsd' field in the referent of the tag pointer,
6232 and instead the tsd pointer is stored just before the dispatch
6233 table. */
e802dbe0 6234
1b611343
JB
6235 type = ada_get_tsd_type (current_inferior());
6236 if (type == NULL)
6237 return NULL;
6238 type = lookup_pointer_type (lookup_pointer_type (type));
6239 val = value_cast (type, tag);
6240 if (val == NULL)
6241 return NULL;
6242 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6243}
6244
1b611343
JB
6245/* Given the TSD of a tag (type-specific data), return a string
6246 containing the name of the associated type.
6247
6248 The returned value is good until the next call. May return NULL
6249 if we are unable to determine the tag name. */
6250
6251static char *
6252ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6253{
529cad9c
PH
6254 static char name[1024];
6255 char *p;
1b611343 6256 struct value *val;
529cad9c 6257
1b611343 6258 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6259 if (val == NULL)
1b611343 6260 return NULL;
4c4b4cd2
PH
6261 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6262 for (p = name; *p != '\0'; p += 1)
6263 if (isalpha (*p))
6264 *p = tolower (*p);
1b611343 6265 return name;
4c4b4cd2
PH
6266}
6267
6268/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6269 a C string.
6270
6271 Return NULL if the TAG is not an Ada tag, or if we were unable to
6272 determine the name of that tag. The result is good until the next
6273 call. */
4c4b4cd2
PH
6274
6275const char *
6276ada_tag_name (struct value *tag)
6277{
1b611343
JB
6278 volatile struct gdb_exception e;
6279 char *name = NULL;
5b4ee69b 6280
df407dfe 6281 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6282 return NULL;
1b611343
JB
6283
6284 /* It is perfectly possible that an exception be raised while trying
6285 to determine the TAG's name, even under normal circumstances:
6286 The associated variable may be uninitialized or corrupted, for
6287 instance. We do not let any exception propagate past this point.
6288 instead we return NULL.
6289
6290 We also do not print the error message either (which often is very
6291 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6292 the caller print a more meaningful message if necessary. */
6293 TRY_CATCH (e, RETURN_MASK_ERROR)
6294 {
6295 struct value *tsd = ada_get_tsd_from_tag (tag);
6296
6297 if (tsd != NULL)
6298 name = ada_tag_name_from_tsd (tsd);
6299 }
6300
6301 return name;
4c4b4cd2
PH
6302}
6303
6304/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6305
d2e4a39e 6306struct type *
ebf56fd3 6307ada_parent_type (struct type *type)
14f9c5c9
AS
6308{
6309 int i;
6310
61ee279c 6311 type = ada_check_typedef (type);
14f9c5c9
AS
6312
6313 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6314 return NULL;
6315
6316 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6317 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6318 {
6319 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6320
6321 /* If the _parent field is a pointer, then dereference it. */
6322 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6323 parent_type = TYPE_TARGET_TYPE (parent_type);
6324 /* If there is a parallel XVS type, get the actual base type. */
6325 parent_type = ada_get_base_type (parent_type);
6326
6327 return ada_check_typedef (parent_type);
6328 }
14f9c5c9
AS
6329
6330 return NULL;
6331}
6332
4c4b4cd2
PH
6333/* True iff field number FIELD_NUM of structure type TYPE contains the
6334 parent-type (inherited) fields of a derived type. Assumes TYPE is
6335 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6336
6337int
ebf56fd3 6338ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6339{
61ee279c 6340 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6341
4c4b4cd2
PH
6342 return (name != NULL
6343 && (strncmp (name, "PARENT", 6) == 0
6344 || strncmp (name, "_parent", 7) == 0));
14f9c5c9
AS
6345}
6346
4c4b4cd2 6347/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6348 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6349 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6350 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6351 structures. */
14f9c5c9
AS
6352
6353int
ebf56fd3 6354ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6355{
d2e4a39e 6356 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6357
d2e4a39e 6358 return (name != NULL
4c4b4cd2
PH
6359 && (strncmp (name, "PARENT", 6) == 0
6360 || strcmp (name, "REP") == 0
6361 || strncmp (name, "_parent", 7) == 0
6362 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6363}
6364
4c4b4cd2
PH
6365/* True iff field number FIELD_NUM of structure or union type TYPE
6366 is a variant wrapper. Assumes TYPE is a structure type with at least
6367 FIELD_NUM+1 fields. */
14f9c5c9
AS
6368
6369int
ebf56fd3 6370ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6371{
d2e4a39e 6372 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6373
14f9c5c9 6374 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6375 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6376 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6377 == TYPE_CODE_UNION)));
14f9c5c9
AS
6378}
6379
6380/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6381 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6382 returns the type of the controlling discriminant for the variant.
6383 May return NULL if the type could not be found. */
14f9c5c9 6384
d2e4a39e 6385struct type *
ebf56fd3 6386ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6387{
d2e4a39e 6388 char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6389
7c964f07 6390 return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
14f9c5c9
AS
6391}
6392
4c4b4cd2 6393/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6394 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6395 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6396
6397int
ebf56fd3 6398ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6399{
d2e4a39e 6400 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6401
14f9c5c9
AS
6402 return (name != NULL && name[0] == 'O');
6403}
6404
6405/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
6406 returns the name of the discriminant controlling the variant.
6407 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 6408
d2e4a39e 6409char *
ebf56fd3 6410ada_variant_discrim_name (struct type *type0)
14f9c5c9 6411{
d2e4a39e 6412 static char *result = NULL;
14f9c5c9 6413 static size_t result_len = 0;
d2e4a39e
AS
6414 struct type *type;
6415 const char *name;
6416 const char *discrim_end;
6417 const char *discrim_start;
14f9c5c9
AS
6418
6419 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6420 type = TYPE_TARGET_TYPE (type0);
6421 else
6422 type = type0;
6423
6424 name = ada_type_name (type);
6425
6426 if (name == NULL || name[0] == '\000')
6427 return "";
6428
6429 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6430 discrim_end -= 1)
6431 {
4c4b4cd2
PH
6432 if (strncmp (discrim_end, "___XVN", 6) == 0)
6433 break;
14f9c5c9
AS
6434 }
6435 if (discrim_end == name)
6436 return "";
6437
d2e4a39e 6438 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
6439 discrim_start -= 1)
6440 {
d2e4a39e 6441 if (discrim_start == name + 1)
4c4b4cd2 6442 return "";
76a01679 6443 if ((discrim_start > name + 3
4c4b4cd2
PH
6444 && strncmp (discrim_start - 3, "___", 3) == 0)
6445 || discrim_start[-1] == '.')
6446 break;
14f9c5c9
AS
6447 }
6448
6449 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6450 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 6451 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
6452 return result;
6453}
6454
4c4b4cd2
PH
6455/* Scan STR for a subtype-encoded number, beginning at position K.
6456 Put the position of the character just past the number scanned in
6457 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6458 Return 1 if there was a valid number at the given position, and 0
6459 otherwise. A "subtype-encoded" number consists of the absolute value
6460 in decimal, followed by the letter 'm' to indicate a negative number.
6461 Assumes 0m does not occur. */
14f9c5c9
AS
6462
6463int
d2e4a39e 6464ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
6465{
6466 ULONGEST RU;
6467
d2e4a39e 6468 if (!isdigit (str[k]))
14f9c5c9
AS
6469 return 0;
6470
4c4b4cd2 6471 /* Do it the hard way so as not to make any assumption about
14f9c5c9 6472 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 6473 LONGEST. */
14f9c5c9
AS
6474 RU = 0;
6475 while (isdigit (str[k]))
6476 {
d2e4a39e 6477 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
6478 k += 1;
6479 }
6480
d2e4a39e 6481 if (str[k] == 'm')
14f9c5c9
AS
6482 {
6483 if (R != NULL)
4c4b4cd2 6484 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
6485 k += 1;
6486 }
6487 else if (R != NULL)
6488 *R = (LONGEST) RU;
6489
4c4b4cd2 6490 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
6491 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6492 number representable as a LONGEST (although either would probably work
6493 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 6494 above is always equivalent to the negative of RU. */
14f9c5c9
AS
6495
6496 if (new_k != NULL)
6497 *new_k = k;
6498 return 1;
6499}
6500
4c4b4cd2
PH
6501/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6502 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6503 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 6504
d2e4a39e 6505int
ebf56fd3 6506ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 6507{
d2e4a39e 6508 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
6509 int p;
6510
6511 p = 0;
6512 while (1)
6513 {
d2e4a39e 6514 switch (name[p])
4c4b4cd2
PH
6515 {
6516 case '\0':
6517 return 0;
6518 case 'S':
6519 {
6520 LONGEST W;
5b4ee69b 6521
4c4b4cd2
PH
6522 if (!ada_scan_number (name, p + 1, &W, &p))
6523 return 0;
6524 if (val == W)
6525 return 1;
6526 break;
6527 }
6528 case 'R':
6529 {
6530 LONGEST L, U;
5b4ee69b 6531
4c4b4cd2
PH
6532 if (!ada_scan_number (name, p + 1, &L, &p)
6533 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6534 return 0;
6535 if (val >= L && val <= U)
6536 return 1;
6537 break;
6538 }
6539 case 'O':
6540 return 1;
6541 default:
6542 return 0;
6543 }
6544 }
6545}
6546
0963b4bd 6547/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
6548
6549/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6550 ARG_TYPE, extract and return the value of one of its (non-static)
6551 fields. FIELDNO says which field. Differs from value_primitive_field
6552 only in that it can handle packed values of arbitrary type. */
14f9c5c9 6553
4c4b4cd2 6554static struct value *
d2e4a39e 6555ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 6556 struct type *arg_type)
14f9c5c9 6557{
14f9c5c9
AS
6558 struct type *type;
6559
61ee279c 6560 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
6561 type = TYPE_FIELD_TYPE (arg_type, fieldno);
6562
4c4b4cd2 6563 /* Handle packed fields. */
14f9c5c9
AS
6564
6565 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
6566 {
6567 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6568 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 6569
0fd88904 6570 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
6571 offset + bit_pos / 8,
6572 bit_pos % 8, bit_size, type);
14f9c5c9
AS
6573 }
6574 else
6575 return value_primitive_field (arg1, offset, fieldno, arg_type);
6576}
6577
52ce6436
PH
6578/* Find field with name NAME in object of type TYPE. If found,
6579 set the following for each argument that is non-null:
6580 - *FIELD_TYPE_P to the field's type;
6581 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6582 an object of that type;
6583 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6584 - *BIT_SIZE_P to its size in bits if the field is packed, and
6585 0 otherwise;
6586 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6587 fields up to but not including the desired field, or by the total
6588 number of fields if not found. A NULL value of NAME never
6589 matches; the function just counts visible fields in this case.
6590
0963b4bd 6591 Returns 1 if found, 0 otherwise. */
52ce6436 6592
4c4b4cd2 6593static int
0d5cff50 6594find_struct_field (const char *name, struct type *type, int offset,
76a01679 6595 struct type **field_type_p,
52ce6436
PH
6596 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6597 int *index_p)
4c4b4cd2
PH
6598{
6599 int i;
6600
61ee279c 6601 type = ada_check_typedef (type);
76a01679 6602
52ce6436
PH
6603 if (field_type_p != NULL)
6604 *field_type_p = NULL;
6605 if (byte_offset_p != NULL)
d5d6fca5 6606 *byte_offset_p = 0;
52ce6436
PH
6607 if (bit_offset_p != NULL)
6608 *bit_offset_p = 0;
6609 if (bit_size_p != NULL)
6610 *bit_size_p = 0;
6611
6612 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
6613 {
6614 int bit_pos = TYPE_FIELD_BITPOS (type, i);
6615 int fld_offset = offset + bit_pos / 8;
0d5cff50 6616 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 6617
4c4b4cd2
PH
6618 if (t_field_name == NULL)
6619 continue;
6620
52ce6436 6621 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
6622 {
6623 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 6624
52ce6436
PH
6625 if (field_type_p != NULL)
6626 *field_type_p = TYPE_FIELD_TYPE (type, i);
6627 if (byte_offset_p != NULL)
6628 *byte_offset_p = fld_offset;
6629 if (bit_offset_p != NULL)
6630 *bit_offset_p = bit_pos % 8;
6631 if (bit_size_p != NULL)
6632 *bit_size_p = bit_size;
76a01679
JB
6633 return 1;
6634 }
4c4b4cd2
PH
6635 else if (ada_is_wrapper_field (type, i))
6636 {
52ce6436
PH
6637 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
6638 field_type_p, byte_offset_p, bit_offset_p,
6639 bit_size_p, index_p))
76a01679
JB
6640 return 1;
6641 }
4c4b4cd2
PH
6642 else if (ada_is_variant_part (type, i))
6643 {
52ce6436
PH
6644 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6645 fixed type?? */
4c4b4cd2 6646 int j;
52ce6436
PH
6647 struct type *field_type
6648 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 6649
52ce6436 6650 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6651 {
76a01679
JB
6652 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
6653 fld_offset
6654 + TYPE_FIELD_BITPOS (field_type, j) / 8,
6655 field_type_p, byte_offset_p,
52ce6436 6656 bit_offset_p, bit_size_p, index_p))
76a01679 6657 return 1;
4c4b4cd2
PH
6658 }
6659 }
52ce6436
PH
6660 else if (index_p != NULL)
6661 *index_p += 1;
4c4b4cd2
PH
6662 }
6663 return 0;
6664}
6665
0963b4bd 6666/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 6667
52ce6436
PH
6668static int
6669num_visible_fields (struct type *type)
6670{
6671 int n;
5b4ee69b 6672
52ce6436
PH
6673 n = 0;
6674 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6675 return n;
6676}
14f9c5c9 6677
4c4b4cd2 6678/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
6679 and search in it assuming it has (class) type TYPE.
6680 If found, return value, else return NULL.
6681
4c4b4cd2 6682 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 6683
4c4b4cd2 6684static struct value *
d2e4a39e 6685ada_search_struct_field (char *name, struct value *arg, int offset,
4c4b4cd2 6686 struct type *type)
14f9c5c9
AS
6687{
6688 int i;
14f9c5c9 6689
5b4ee69b 6690 type = ada_check_typedef (type);
52ce6436 6691 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 6692 {
0d5cff50 6693 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
6694
6695 if (t_field_name == NULL)
4c4b4cd2 6696 continue;
14f9c5c9
AS
6697
6698 else if (field_name_match (t_field_name, name))
4c4b4cd2 6699 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
6700
6701 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 6702 {
0963b4bd 6703 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
6704 ada_search_struct_field (name, arg,
6705 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6706 TYPE_FIELD_TYPE (type, i));
5b4ee69b 6707
4c4b4cd2
PH
6708 if (v != NULL)
6709 return v;
6710 }
14f9c5c9
AS
6711
6712 else if (ada_is_variant_part (type, i))
4c4b4cd2 6713 {
0963b4bd 6714 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 6715 int j;
5b4ee69b
MS
6716 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
6717 i));
4c4b4cd2
PH
6718 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6719
52ce6436 6720 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6721 {
0963b4bd
MS
6722 struct value *v = ada_search_struct_field /* Force line
6723 break. */
06d5cf63
JB
6724 (name, arg,
6725 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6726 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 6727
4c4b4cd2
PH
6728 if (v != NULL)
6729 return v;
6730 }
6731 }
14f9c5c9
AS
6732 }
6733 return NULL;
6734}
d2e4a39e 6735
52ce6436
PH
6736static struct value *ada_index_struct_field_1 (int *, struct value *,
6737 int, struct type *);
6738
6739
6740/* Return field #INDEX in ARG, where the index is that returned by
6741 * find_struct_field through its INDEX_P argument. Adjust the address
6742 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 6743 * If found, return value, else return NULL. */
52ce6436
PH
6744
6745static struct value *
6746ada_index_struct_field (int index, struct value *arg, int offset,
6747 struct type *type)
6748{
6749 return ada_index_struct_field_1 (&index, arg, offset, type);
6750}
6751
6752
6753/* Auxiliary function for ada_index_struct_field. Like
6754 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 6755 * *INDEX_P. */
52ce6436
PH
6756
6757static struct value *
6758ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6759 struct type *type)
6760{
6761 int i;
6762 type = ada_check_typedef (type);
6763
6764 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6765 {
6766 if (TYPE_FIELD_NAME (type, i) == NULL)
6767 continue;
6768 else if (ada_is_wrapper_field (type, i))
6769 {
0963b4bd 6770 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
6771 ada_index_struct_field_1 (index_p, arg,
6772 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6773 TYPE_FIELD_TYPE (type, i));
5b4ee69b 6774
52ce6436
PH
6775 if (v != NULL)
6776 return v;
6777 }
6778
6779 else if (ada_is_variant_part (type, i))
6780 {
6781 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 6782 find_struct_field. */
52ce6436
PH
6783 error (_("Cannot assign this kind of variant record"));
6784 }
6785 else if (*index_p == 0)
6786 return ada_value_primitive_field (arg, offset, i, type);
6787 else
6788 *index_p -= 1;
6789 }
6790 return NULL;
6791}
6792
4c4b4cd2
PH
6793/* Given ARG, a value of type (pointer or reference to a)*
6794 structure/union, extract the component named NAME from the ultimate
6795 target structure/union and return it as a value with its
f5938064 6796 appropriate type.
14f9c5c9 6797
4c4b4cd2
PH
6798 The routine searches for NAME among all members of the structure itself
6799 and (recursively) among all members of any wrapper members
14f9c5c9
AS
6800 (e.g., '_parent').
6801
03ee6b2e
PH
6802 If NO_ERR, then simply return NULL in case of error, rather than
6803 calling error. */
14f9c5c9 6804
d2e4a39e 6805struct value *
03ee6b2e 6806ada_value_struct_elt (struct value *arg, char *name, int no_err)
14f9c5c9 6807{
4c4b4cd2 6808 struct type *t, *t1;
d2e4a39e 6809 struct value *v;
14f9c5c9 6810
4c4b4cd2 6811 v = NULL;
df407dfe 6812 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
6813 if (TYPE_CODE (t) == TYPE_CODE_REF)
6814 {
6815 t1 = TYPE_TARGET_TYPE (t);
6816 if (t1 == NULL)
03ee6b2e 6817 goto BadValue;
61ee279c 6818 t1 = ada_check_typedef (t1);
4c4b4cd2 6819 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 6820 {
994b9211 6821 arg = coerce_ref (arg);
76a01679
JB
6822 t = t1;
6823 }
4c4b4cd2 6824 }
14f9c5c9 6825
4c4b4cd2
PH
6826 while (TYPE_CODE (t) == TYPE_CODE_PTR)
6827 {
6828 t1 = TYPE_TARGET_TYPE (t);
6829 if (t1 == NULL)
03ee6b2e 6830 goto BadValue;
61ee279c 6831 t1 = ada_check_typedef (t1);
4c4b4cd2 6832 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
6833 {
6834 arg = value_ind (arg);
6835 t = t1;
6836 }
4c4b4cd2 6837 else
76a01679 6838 break;
4c4b4cd2 6839 }
14f9c5c9 6840
4c4b4cd2 6841 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 6842 goto BadValue;
14f9c5c9 6843
4c4b4cd2
PH
6844 if (t1 == t)
6845 v = ada_search_struct_field (name, arg, 0, t);
6846 else
6847 {
6848 int bit_offset, bit_size, byte_offset;
6849 struct type *field_type;
6850 CORE_ADDR address;
6851
76a01679 6852 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 6853 address = value_address (ada_value_ind (arg));
4c4b4cd2 6854 else
b50d69b5 6855 address = value_address (ada_coerce_ref (arg));
14f9c5c9 6856
1ed6ede0 6857 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
76a01679
JB
6858 if (find_struct_field (name, t1, 0,
6859 &field_type, &byte_offset, &bit_offset,
52ce6436 6860 &bit_size, NULL))
76a01679
JB
6861 {
6862 if (bit_size != 0)
6863 {
714e53ab
PH
6864 if (TYPE_CODE (t) == TYPE_CODE_REF)
6865 arg = ada_coerce_ref (arg);
6866 else
6867 arg = ada_value_ind (arg);
76a01679
JB
6868 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
6869 bit_offset, bit_size,
6870 field_type);
6871 }
6872 else
f5938064 6873 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
6874 }
6875 }
6876
03ee6b2e
PH
6877 if (v != NULL || no_err)
6878 return v;
6879 else
323e0a4a 6880 error (_("There is no member named %s."), name);
14f9c5c9 6881
03ee6b2e
PH
6882 BadValue:
6883 if (no_err)
6884 return NULL;
6885 else
0963b4bd
MS
6886 error (_("Attempt to extract a component of "
6887 "a value that is not a record."));
14f9c5c9
AS
6888}
6889
6890/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
6891 If DISPP is non-null, add its byte displacement from the beginning of a
6892 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
6893 work for packed fields).
6894
6895 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 6896 followed by "___".
14f9c5c9 6897
0963b4bd 6898 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
6899 be a (pointer or reference)+ to a struct or union, and the
6900 ultimate target type will be searched.
14f9c5c9
AS
6901
6902 Looks recursively into variant clauses and parent types.
6903
4c4b4cd2
PH
6904 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6905 TYPE is not a type of the right kind. */
14f9c5c9 6906
4c4b4cd2 6907static struct type *
76a01679
JB
6908ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
6909 int noerr, int *dispp)
14f9c5c9
AS
6910{
6911 int i;
6912
6913 if (name == NULL)
6914 goto BadName;
6915
76a01679 6916 if (refok && type != NULL)
4c4b4cd2
PH
6917 while (1)
6918 {
61ee279c 6919 type = ada_check_typedef (type);
76a01679
JB
6920 if (TYPE_CODE (type) != TYPE_CODE_PTR
6921 && TYPE_CODE (type) != TYPE_CODE_REF)
6922 break;
6923 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 6924 }
14f9c5c9 6925
76a01679 6926 if (type == NULL
1265e4aa
JB
6927 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
6928 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 6929 {
4c4b4cd2 6930 if (noerr)
76a01679 6931 return NULL;
4c4b4cd2 6932 else
76a01679
JB
6933 {
6934 target_terminal_ours ();
6935 gdb_flush (gdb_stdout);
323e0a4a
AC
6936 if (type == NULL)
6937 error (_("Type (null) is not a structure or union type"));
6938 else
6939 {
6940 /* XXX: type_sprint */
6941 fprintf_unfiltered (gdb_stderr, _("Type "));
6942 type_print (type, "", gdb_stderr, -1);
6943 error (_(" is not a structure or union type"));
6944 }
76a01679 6945 }
14f9c5c9
AS
6946 }
6947
6948 type = to_static_fixed_type (type);
6949
6950 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6951 {
0d5cff50 6952 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
6953 struct type *t;
6954 int disp;
d2e4a39e 6955
14f9c5c9 6956 if (t_field_name == NULL)
4c4b4cd2 6957 continue;
14f9c5c9
AS
6958
6959 else if (field_name_match (t_field_name, name))
4c4b4cd2
PH
6960 {
6961 if (dispp != NULL)
6962 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
61ee279c 6963 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 6964 }
14f9c5c9
AS
6965
6966 else if (ada_is_wrapper_field (type, i))
4c4b4cd2
PH
6967 {
6968 disp = 0;
6969 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
6970 0, 1, &disp);
6971 if (t != NULL)
6972 {
6973 if (dispp != NULL)
6974 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6975 return t;
6976 }
6977 }
14f9c5c9
AS
6978
6979 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
6980 {
6981 int j;
5b4ee69b
MS
6982 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
6983 i));
4c4b4cd2
PH
6984
6985 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
6986 {
b1f33ddd
JB
6987 /* FIXME pnh 2008/01/26: We check for a field that is
6988 NOT wrapped in a struct, since the compiler sometimes
6989 generates these for unchecked variant types. Revisit
0963b4bd 6990 if the compiler changes this practice. */
0d5cff50 6991 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
4c4b4cd2 6992 disp = 0;
b1f33ddd
JB
6993 if (v_field_name != NULL
6994 && field_name_match (v_field_name, name))
6995 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
6996 else
0963b4bd
MS
6997 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
6998 j),
b1f33ddd
JB
6999 name, 0, 1, &disp);
7000
4c4b4cd2
PH
7001 if (t != NULL)
7002 {
7003 if (dispp != NULL)
7004 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7005 return t;
7006 }
7007 }
7008 }
14f9c5c9
AS
7009
7010 }
7011
7012BadName:
d2e4a39e 7013 if (!noerr)
14f9c5c9
AS
7014 {
7015 target_terminal_ours ();
7016 gdb_flush (gdb_stdout);
323e0a4a
AC
7017 if (name == NULL)
7018 {
7019 /* XXX: type_sprint */
7020 fprintf_unfiltered (gdb_stderr, _("Type "));
7021 type_print (type, "", gdb_stderr, -1);
7022 error (_(" has no component named <null>"));
7023 }
7024 else
7025 {
7026 /* XXX: type_sprint */
7027 fprintf_unfiltered (gdb_stderr, _("Type "));
7028 type_print (type, "", gdb_stderr, -1);
7029 error (_(" has no component named %s"), name);
7030 }
14f9c5c9
AS
7031 }
7032
7033 return NULL;
7034}
7035
b1f33ddd
JB
7036/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7037 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7038 represents an unchecked union (that is, the variant part of a
0963b4bd 7039 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7040
7041static int
7042is_unchecked_variant (struct type *var_type, struct type *outer_type)
7043{
7044 char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7045
b1f33ddd
JB
7046 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
7047 == NULL);
7048}
7049
7050
14f9c5c9
AS
7051/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7052 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7053 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7054 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7055
d2e4a39e 7056int
ebf56fd3 7057ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7058 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7059{
7060 int others_clause;
7061 int i;
d2e4a39e 7062 char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7063 struct value *outer;
7064 struct value *discrim;
14f9c5c9
AS
7065 LONGEST discrim_val;
7066
0c281816
JB
7067 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
7068 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7069 if (discrim == NULL)
14f9c5c9 7070 return -1;
0c281816 7071 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7072
7073 others_clause = -1;
7074 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7075 {
7076 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7077 others_clause = i;
14f9c5c9 7078 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7079 return i;
14f9c5c9
AS
7080 }
7081
7082 return others_clause;
7083}
d2e4a39e 7084\f
14f9c5c9
AS
7085
7086
4c4b4cd2 7087 /* Dynamic-Sized Records */
14f9c5c9
AS
7088
7089/* Strategy: The type ostensibly attached to a value with dynamic size
7090 (i.e., a size that is not statically recorded in the debugging
7091 data) does not accurately reflect the size or layout of the value.
7092 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7093 conventional types that are constructed on the fly. */
14f9c5c9
AS
7094
7095/* There is a subtle and tricky problem here. In general, we cannot
7096 determine the size of dynamic records without its data. However,
7097 the 'struct value' data structure, which GDB uses to represent
7098 quantities in the inferior process (the target), requires the size
7099 of the type at the time of its allocation in order to reserve space
7100 for GDB's internal copy of the data. That's why the
7101 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7102 rather than struct value*s.
14f9c5c9
AS
7103
7104 However, GDB's internal history variables ($1, $2, etc.) are
7105 struct value*s containing internal copies of the data that are not, in
7106 general, the same as the data at their corresponding addresses in
7107 the target. Fortunately, the types we give to these values are all
7108 conventional, fixed-size types (as per the strategy described
7109 above), so that we don't usually have to perform the
7110 'to_fixed_xxx_type' conversions to look at their values.
7111 Unfortunately, there is one exception: if one of the internal
7112 history variables is an array whose elements are unconstrained
7113 records, then we will need to create distinct fixed types for each
7114 element selected. */
7115
7116/* The upshot of all of this is that many routines take a (type, host
7117 address, target address) triple as arguments to represent a value.
7118 The host address, if non-null, is supposed to contain an internal
7119 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7120 target at the target address. */
14f9c5c9
AS
7121
7122/* Assuming that VAL0 represents a pointer value, the result of
7123 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7124 dynamic-sized types. */
14f9c5c9 7125
d2e4a39e
AS
7126struct value *
7127ada_value_ind (struct value *val0)
14f9c5c9 7128{
c48db5ca 7129 struct value *val = value_ind (val0);
5b4ee69b 7130
b50d69b5
JG
7131 if (ada_is_tagged_type (value_type (val), 0))
7132 val = ada_tag_value_at_base_address (val);
7133
4c4b4cd2 7134 return ada_to_fixed_value (val);
14f9c5c9
AS
7135}
7136
7137/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7138 qualifiers on VAL0. */
7139
d2e4a39e
AS
7140static struct value *
7141ada_coerce_ref (struct value *val0)
7142{
df407dfe 7143 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7144 {
7145 struct value *val = val0;
5b4ee69b 7146
994b9211 7147 val = coerce_ref (val);
b50d69b5
JG
7148
7149 if (ada_is_tagged_type (value_type (val), 0))
7150 val = ada_tag_value_at_base_address (val);
7151
4c4b4cd2 7152 return ada_to_fixed_value (val);
d2e4a39e
AS
7153 }
7154 else
14f9c5c9
AS
7155 return val0;
7156}
7157
7158/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7159 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7160
7161static unsigned int
ebf56fd3 7162align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7163{
7164 return (off + alignment - 1) & ~(alignment - 1);
7165}
7166
4c4b4cd2 7167/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7168
7169static unsigned int
ebf56fd3 7170field_alignment (struct type *type, int f)
14f9c5c9 7171{
d2e4a39e 7172 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7173 int len;
14f9c5c9
AS
7174 int align_offset;
7175
64a1bf19
JB
7176 /* The field name should never be null, unless the debugging information
7177 is somehow malformed. In this case, we assume the field does not
7178 require any alignment. */
7179 if (name == NULL)
7180 return 1;
7181
7182 len = strlen (name);
7183
4c4b4cd2
PH
7184 if (!isdigit (name[len - 1]))
7185 return 1;
14f9c5c9 7186
d2e4a39e 7187 if (isdigit (name[len - 2]))
14f9c5c9
AS
7188 align_offset = len - 2;
7189 else
7190 align_offset = len - 1;
7191
4c4b4cd2 7192 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
14f9c5c9
AS
7193 return TARGET_CHAR_BIT;
7194
4c4b4cd2
PH
7195 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7196}
7197
852dff6c 7198/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7199
852dff6c
JB
7200static struct symbol *
7201ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7202{
7203 struct symbol *sym;
7204
7205 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7206 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7207 return sym;
7208
7209 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7210 return sym;
14f9c5c9
AS
7211}
7212
dddfab26
UW
7213/* Find a type named NAME. Ignores ambiguity. This routine will look
7214 solely for types defined by debug info, it will not search the GDB
7215 primitive types. */
4c4b4cd2 7216
852dff6c 7217static struct type *
ebf56fd3 7218ada_find_any_type (const char *name)
14f9c5c9 7219{
852dff6c 7220 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7221
14f9c5c9 7222 if (sym != NULL)
dddfab26 7223 return SYMBOL_TYPE (sym);
14f9c5c9 7224
dddfab26 7225 return NULL;
14f9c5c9
AS
7226}
7227
739593e0
JB
7228/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7229 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7230 symbol, in which case it is returned. Otherwise, this looks for
7231 symbols whose name is that of NAME_SYM suffixed with "___XR".
7232 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7233
7234struct symbol *
270140bd 7235ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7236{
739593e0 7237 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7238 struct symbol *sym;
7239
739593e0
JB
7240 if (strstr (name, "___XR") != NULL)
7241 return name_sym;
7242
aeb5907d
JB
7243 sym = find_old_style_renaming_symbol (name, block);
7244
7245 if (sym != NULL)
7246 return sym;
7247
0963b4bd 7248 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7249 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7250 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7251 return sym;
7252 else
7253 return NULL;
7254}
7255
7256static struct symbol *
270140bd 7257find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 7258{
7f0df278 7259 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
7260 char *rename;
7261
7262 if (function_sym != NULL)
7263 {
7264 /* If the symbol is defined inside a function, NAME is not fully
7265 qualified. This means we need to prepend the function name
7266 as well as adding the ``___XR'' suffix to build the name of
7267 the associated renaming symbol. */
0d5cff50 7268 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
7269 /* Function names sometimes contain suffixes used
7270 for instance to qualify nested subprograms. When building
7271 the XR type name, we need to make sure that this suffix is
7272 not included. So do not include any suffix in the function
7273 name length below. */
69fadcdf 7274 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
7275 const int rename_len = function_name_len + 2 /* "__" */
7276 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 7277
529cad9c 7278 /* Strip the suffix if necessary. */
69fadcdf
JB
7279 ada_remove_trailing_digits (function_name, &function_name_len);
7280 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7281 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 7282
4c4b4cd2
PH
7283 /* Library-level functions are a special case, as GNAT adds
7284 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 7285 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
7286 have this prefix, so we need to skip this prefix if present. */
7287 if (function_name_len > 5 /* "_ada_" */
7288 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
7289 {
7290 function_name += 5;
7291 function_name_len -= 5;
7292 }
4c4b4cd2
PH
7293
7294 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
7295 strncpy (rename, function_name, function_name_len);
7296 xsnprintf (rename + function_name_len, rename_len - function_name_len,
7297 "__%s___XR", name);
4c4b4cd2
PH
7298 }
7299 else
7300 {
7301 const int rename_len = strlen (name) + 6;
5b4ee69b 7302
4c4b4cd2 7303 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 7304 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
7305 }
7306
852dff6c 7307 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
7308}
7309
14f9c5c9 7310/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 7311 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 7312 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
7313 otherwise return 0. */
7314
14f9c5c9 7315int
d2e4a39e 7316ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
7317{
7318 if (type1 == NULL)
7319 return 1;
7320 else if (type0 == NULL)
7321 return 0;
7322 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7323 return 1;
7324 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7325 return 0;
4c4b4cd2
PH
7326 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7327 return 1;
ad82864c 7328 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 7329 return 1;
4c4b4cd2
PH
7330 else if (ada_is_array_descriptor_type (type0)
7331 && !ada_is_array_descriptor_type (type1))
14f9c5c9 7332 return 1;
aeb5907d
JB
7333 else
7334 {
7335 const char *type0_name = type_name_no_tag (type0);
7336 const char *type1_name = type_name_no_tag (type1);
7337
7338 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7339 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7340 return 1;
7341 }
14f9c5c9
AS
7342 return 0;
7343}
7344
7345/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
7346 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7347
0d5cff50 7348const char *
d2e4a39e 7349ada_type_name (struct type *type)
14f9c5c9 7350{
d2e4a39e 7351 if (type == NULL)
14f9c5c9
AS
7352 return NULL;
7353 else if (TYPE_NAME (type) != NULL)
7354 return TYPE_NAME (type);
7355 else
7356 return TYPE_TAG_NAME (type);
7357}
7358
b4ba55a1
JB
7359/* Search the list of "descriptive" types associated to TYPE for a type
7360 whose name is NAME. */
7361
7362static struct type *
7363find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7364{
7365 struct type *result;
7366
7367 /* If there no descriptive-type info, then there is no parallel type
7368 to be found. */
7369 if (!HAVE_GNAT_AUX_INFO (type))
7370 return NULL;
7371
7372 result = TYPE_DESCRIPTIVE_TYPE (type);
7373 while (result != NULL)
7374 {
0d5cff50 7375 const char *result_name = ada_type_name (result);
b4ba55a1
JB
7376
7377 if (result_name == NULL)
7378 {
7379 warning (_("unexpected null name on descriptive type"));
7380 return NULL;
7381 }
7382
7383 /* If the names match, stop. */
7384 if (strcmp (result_name, name) == 0)
7385 break;
7386
7387 /* Otherwise, look at the next item on the list, if any. */
7388 if (HAVE_GNAT_AUX_INFO (result))
7389 result = TYPE_DESCRIPTIVE_TYPE (result);
7390 else
7391 result = NULL;
7392 }
7393
7394 /* If we didn't find a match, see whether this is a packed array. With
7395 older compilers, the descriptive type information is either absent or
7396 irrelevant when it comes to packed arrays so the above lookup fails.
7397 Fall back to using a parallel lookup by name in this case. */
12ab9e09 7398 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
7399 return ada_find_any_type (name);
7400
7401 return result;
7402}
7403
7404/* Find a parallel type to TYPE with the specified NAME, using the
7405 descriptive type taken from the debugging information, if available,
7406 and otherwise using the (slower) name-based method. */
7407
7408static struct type *
7409ada_find_parallel_type_with_name (struct type *type, const char *name)
7410{
7411 struct type *result = NULL;
7412
7413 if (HAVE_GNAT_AUX_INFO (type))
7414 result = find_parallel_type_by_descriptive_type (type, name);
7415 else
7416 result = ada_find_any_type (name);
7417
7418 return result;
7419}
7420
7421/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 7422 SUFFIX to the name of TYPE. */
14f9c5c9 7423
d2e4a39e 7424struct type *
ebf56fd3 7425ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 7426{
0d5cff50
DE
7427 char *name;
7428 const char *typename = ada_type_name (type);
14f9c5c9 7429 int len;
d2e4a39e 7430
14f9c5c9
AS
7431 if (typename == NULL)
7432 return NULL;
7433
7434 len = strlen (typename);
7435
b4ba55a1 7436 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9
AS
7437
7438 strcpy (name, typename);
7439 strcpy (name + len, suffix);
7440
b4ba55a1 7441 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
7442}
7443
14f9c5c9 7444/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 7445 type describing its fields. Otherwise, return NULL. */
14f9c5c9 7446
d2e4a39e
AS
7447static struct type *
7448dynamic_template_type (struct type *type)
14f9c5c9 7449{
61ee279c 7450 type = ada_check_typedef (type);
14f9c5c9
AS
7451
7452 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 7453 || ada_type_name (type) == NULL)
14f9c5c9 7454 return NULL;
d2e4a39e 7455 else
14f9c5c9
AS
7456 {
7457 int len = strlen (ada_type_name (type));
5b4ee69b 7458
4c4b4cd2
PH
7459 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7460 return type;
14f9c5c9 7461 else
4c4b4cd2 7462 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
7463 }
7464}
7465
7466/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 7467 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 7468
d2e4a39e
AS
7469static int
7470is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
7471{
7472 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 7473
d2e4a39e 7474 return name != NULL
14f9c5c9
AS
7475 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
7476 && strstr (name, "___XVL") != NULL;
7477}
7478
4c4b4cd2
PH
7479/* The index of the variant field of TYPE, or -1 if TYPE does not
7480 represent a variant record type. */
14f9c5c9 7481
d2e4a39e 7482static int
4c4b4cd2 7483variant_field_index (struct type *type)
14f9c5c9
AS
7484{
7485 int f;
7486
4c4b4cd2
PH
7487 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
7488 return -1;
7489
7490 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
7491 {
7492 if (ada_is_variant_part (type, f))
7493 return f;
7494 }
7495 return -1;
14f9c5c9
AS
7496}
7497
4c4b4cd2
PH
7498/* A record type with no fields. */
7499
d2e4a39e 7500static struct type *
e9bb382b 7501empty_record (struct type *template)
14f9c5c9 7502{
e9bb382b 7503 struct type *type = alloc_type_copy (template);
5b4ee69b 7504
14f9c5c9
AS
7505 TYPE_CODE (type) = TYPE_CODE_STRUCT;
7506 TYPE_NFIELDS (type) = 0;
7507 TYPE_FIELDS (type) = NULL;
b1f33ddd 7508 INIT_CPLUS_SPECIFIC (type);
14f9c5c9
AS
7509 TYPE_NAME (type) = "<empty>";
7510 TYPE_TAG_NAME (type) = NULL;
14f9c5c9
AS
7511 TYPE_LENGTH (type) = 0;
7512 return type;
7513}
7514
7515/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
7516 the value of type TYPE at VALADDR or ADDRESS (see comments at
7517 the beginning of this section) VAL according to GNAT conventions.
7518 DVAL0 should describe the (portion of a) record that contains any
df407dfe 7519 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
7520 an outer-level type (i.e., as opposed to a branch of a variant.) A
7521 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 7522 of the variant.
14f9c5c9 7523
4c4b4cd2
PH
7524 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7525 length are not statically known are discarded. As a consequence,
7526 VALADDR, ADDRESS and DVAL0 are ignored.
7527
7528 NOTE: Limitations: For now, we assume that dynamic fields and
7529 variants occupy whole numbers of bytes. However, they need not be
7530 byte-aligned. */
7531
7532struct type *
10a2c479 7533ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 7534 const gdb_byte *valaddr,
4c4b4cd2
PH
7535 CORE_ADDR address, struct value *dval0,
7536 int keep_dynamic_fields)
14f9c5c9 7537{
d2e4a39e
AS
7538 struct value *mark = value_mark ();
7539 struct value *dval;
7540 struct type *rtype;
14f9c5c9 7541 int nfields, bit_len;
4c4b4cd2 7542 int variant_field;
14f9c5c9 7543 long off;
d94e4f4f 7544 int fld_bit_len;
14f9c5c9
AS
7545 int f;
7546
4c4b4cd2
PH
7547 /* Compute the number of fields in this record type that are going
7548 to be processed: unless keep_dynamic_fields, this includes only
7549 fields whose position and length are static will be processed. */
7550 if (keep_dynamic_fields)
7551 nfields = TYPE_NFIELDS (type);
7552 else
7553 {
7554 nfields = 0;
76a01679 7555 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
7556 && !ada_is_variant_part (type, nfields)
7557 && !is_dynamic_field (type, nfields))
7558 nfields++;
7559 }
7560
e9bb382b 7561 rtype = alloc_type_copy (type);
14f9c5c9
AS
7562 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7563 INIT_CPLUS_SPECIFIC (rtype);
7564 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 7565 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
7566 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7567 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
7568 TYPE_NAME (rtype) = ada_type_name (type);
7569 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7570 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 7571
d2e4a39e
AS
7572 off = 0;
7573 bit_len = 0;
4c4b4cd2
PH
7574 variant_field = -1;
7575
14f9c5c9
AS
7576 for (f = 0; f < nfields; f += 1)
7577 {
6c038f32
PH
7578 off = align_value (off, field_alignment (type, f))
7579 + TYPE_FIELD_BITPOS (type, f);
945b3a32 7580 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 7581 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 7582
d2e4a39e 7583 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
7584 {
7585 variant_field = f;
d94e4f4f 7586 fld_bit_len = 0;
4c4b4cd2 7587 }
14f9c5c9 7588 else if (is_dynamic_field (type, f))
4c4b4cd2 7589 {
284614f0
JB
7590 const gdb_byte *field_valaddr = valaddr;
7591 CORE_ADDR field_address = address;
7592 struct type *field_type =
7593 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
7594
4c4b4cd2 7595 if (dval0 == NULL)
b5304971
JG
7596 {
7597 /* rtype's length is computed based on the run-time
7598 value of discriminants. If the discriminants are not
7599 initialized, the type size may be completely bogus and
0963b4bd 7600 GDB may fail to allocate a value for it. So check the
b5304971
JG
7601 size first before creating the value. */
7602 check_size (rtype);
7603 dval = value_from_contents_and_address (rtype, valaddr, address);
7604 }
4c4b4cd2
PH
7605 else
7606 dval = dval0;
7607
284614f0
JB
7608 /* If the type referenced by this field is an aligner type, we need
7609 to unwrap that aligner type, because its size might not be set.
7610 Keeping the aligner type would cause us to compute the wrong
7611 size for this field, impacting the offset of the all the fields
7612 that follow this one. */
7613 if (ada_is_aligner_type (field_type))
7614 {
7615 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
7616
7617 field_valaddr = cond_offset_host (field_valaddr, field_offset);
7618 field_address = cond_offset_target (field_address, field_offset);
7619 field_type = ada_aligned_type (field_type);
7620 }
7621
7622 field_valaddr = cond_offset_host (field_valaddr,
7623 off / TARGET_CHAR_BIT);
7624 field_address = cond_offset_target (field_address,
7625 off / TARGET_CHAR_BIT);
7626
7627 /* Get the fixed type of the field. Note that, in this case,
7628 we do not want to get the real type out of the tag: if
7629 the current field is the parent part of a tagged record,
7630 we will get the tag of the object. Clearly wrong: the real
7631 type of the parent is not the real type of the child. We
7632 would end up in an infinite loop. */
7633 field_type = ada_get_base_type (field_type);
7634 field_type = ada_to_fixed_type (field_type, field_valaddr,
7635 field_address, dval, 0);
27f2a97b
JB
7636 /* If the field size is already larger than the maximum
7637 object size, then the record itself will necessarily
7638 be larger than the maximum object size. We need to make
7639 this check now, because the size might be so ridiculously
7640 large (due to an uninitialized variable in the inferior)
7641 that it would cause an overflow when adding it to the
7642 record size. */
7643 check_size (field_type);
284614f0
JB
7644
7645 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 7646 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
7647 /* The multiplication can potentially overflow. But because
7648 the field length has been size-checked just above, and
7649 assuming that the maximum size is a reasonable value,
7650 an overflow should not happen in practice. So rather than
7651 adding overflow recovery code to this already complex code,
7652 we just assume that it's not going to happen. */
d94e4f4f 7653 fld_bit_len =
4c4b4cd2
PH
7654 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
7655 }
14f9c5c9 7656 else
4c4b4cd2 7657 {
5ded5331
JB
7658 /* Note: If this field's type is a typedef, it is important
7659 to preserve the typedef layer.
7660
7661 Otherwise, we might be transforming a typedef to a fat
7662 pointer (encoding a pointer to an unconstrained array),
7663 into a basic fat pointer (encoding an unconstrained
7664 array). As both types are implemented using the same
7665 structure, the typedef is the only clue which allows us
7666 to distinguish between the two options. Stripping it
7667 would prevent us from printing this field appropriately. */
7668 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
7669 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7670 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 7671 fld_bit_len =
4c4b4cd2
PH
7672 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7673 else
5ded5331
JB
7674 {
7675 struct type *field_type = TYPE_FIELD_TYPE (type, f);
7676
7677 /* We need to be careful of typedefs when computing
7678 the length of our field. If this is a typedef,
7679 get the length of the target type, not the length
7680 of the typedef. */
7681 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
7682 field_type = ada_typedef_target_type (field_type);
7683
7684 fld_bit_len =
7685 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7686 }
4c4b4cd2 7687 }
14f9c5c9 7688 if (off + fld_bit_len > bit_len)
4c4b4cd2 7689 bit_len = off + fld_bit_len;
d94e4f4f 7690 off += fld_bit_len;
4c4b4cd2
PH
7691 TYPE_LENGTH (rtype) =
7692 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 7693 }
4c4b4cd2
PH
7694
7695 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 7696 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
7697 the record. This can happen in the presence of representation
7698 clauses. */
7699 if (variant_field >= 0)
7700 {
7701 struct type *branch_type;
7702
7703 off = TYPE_FIELD_BITPOS (rtype, variant_field);
7704
7705 if (dval0 == NULL)
7706 dval = value_from_contents_and_address (rtype, valaddr, address);
7707 else
7708 dval = dval0;
7709
7710 branch_type =
7711 to_fixed_variant_branch_type
7712 (TYPE_FIELD_TYPE (type, variant_field),
7713 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7714 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7715 if (branch_type == NULL)
7716 {
7717 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
7718 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7719 TYPE_NFIELDS (rtype) -= 1;
7720 }
7721 else
7722 {
7723 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7724 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7725 fld_bit_len =
7726 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
7727 TARGET_CHAR_BIT;
7728 if (off + fld_bit_len > bit_len)
7729 bit_len = off + fld_bit_len;
7730 TYPE_LENGTH (rtype) =
7731 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7732 }
7733 }
7734
714e53ab
PH
7735 /* According to exp_dbug.ads, the size of TYPE for variable-size records
7736 should contain the alignment of that record, which should be a strictly
7737 positive value. If null or negative, then something is wrong, most
7738 probably in the debug info. In that case, we don't round up the size
0963b4bd 7739 of the resulting type. If this record is not part of another structure,
714e53ab
PH
7740 the current RTYPE length might be good enough for our purposes. */
7741 if (TYPE_LENGTH (type) <= 0)
7742 {
323e0a4a
AC
7743 if (TYPE_NAME (rtype))
7744 warning (_("Invalid type size for `%s' detected: %d."),
7745 TYPE_NAME (rtype), TYPE_LENGTH (type));
7746 else
7747 warning (_("Invalid type size for <unnamed> detected: %d."),
7748 TYPE_LENGTH (type));
714e53ab
PH
7749 }
7750 else
7751 {
7752 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
7753 TYPE_LENGTH (type));
7754 }
14f9c5c9
AS
7755
7756 value_free_to_mark (mark);
d2e4a39e 7757 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 7758 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
7759 return rtype;
7760}
7761
4c4b4cd2
PH
7762/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7763 of 1. */
14f9c5c9 7764
d2e4a39e 7765static struct type *
fc1a4b47 7766template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
7767 CORE_ADDR address, struct value *dval0)
7768{
7769 return ada_template_to_fixed_record_type_1 (type, valaddr,
7770 address, dval0, 1);
7771}
7772
7773/* An ordinary record type in which ___XVL-convention fields and
7774 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7775 static approximations, containing all possible fields. Uses
7776 no runtime values. Useless for use in values, but that's OK,
7777 since the results are used only for type determinations. Works on both
7778 structs and unions. Representation note: to save space, we memorize
7779 the result of this function in the TYPE_TARGET_TYPE of the
7780 template type. */
7781
7782static struct type *
7783template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
7784{
7785 struct type *type;
7786 int nfields;
7787 int f;
7788
4c4b4cd2
PH
7789 if (TYPE_TARGET_TYPE (type0) != NULL)
7790 return TYPE_TARGET_TYPE (type0);
7791
7792 nfields = TYPE_NFIELDS (type0);
7793 type = type0;
14f9c5c9
AS
7794
7795 for (f = 0; f < nfields; f += 1)
7796 {
61ee279c 7797 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
4c4b4cd2 7798 struct type *new_type;
14f9c5c9 7799
4c4b4cd2
PH
7800 if (is_dynamic_field (type0, f))
7801 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
14f9c5c9 7802 else
f192137b 7803 new_type = static_unwrap_type (field_type);
4c4b4cd2
PH
7804 if (type == type0 && new_type != field_type)
7805 {
e9bb382b 7806 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
4c4b4cd2
PH
7807 TYPE_CODE (type) = TYPE_CODE (type0);
7808 INIT_CPLUS_SPECIFIC (type);
7809 TYPE_NFIELDS (type) = nfields;
7810 TYPE_FIELDS (type) = (struct field *)
7811 TYPE_ALLOC (type, nfields * sizeof (struct field));
7812 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
7813 sizeof (struct field) * nfields);
7814 TYPE_NAME (type) = ada_type_name (type0);
7815 TYPE_TAG_NAME (type) = NULL;
876cecd0 7816 TYPE_FIXED_INSTANCE (type) = 1;
4c4b4cd2
PH
7817 TYPE_LENGTH (type) = 0;
7818 }
7819 TYPE_FIELD_TYPE (type, f) = new_type;
7820 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
14f9c5c9 7821 }
14f9c5c9
AS
7822 return type;
7823}
7824
4c4b4cd2 7825/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
7826 whose address in memory is ADDRESS, returns a revision of TYPE,
7827 which should be a non-dynamic-sized record, in which the variant
7828 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
7829 for discriminant values in DVAL0, which can be NULL if the record
7830 contains the necessary discriminant values. */
7831
d2e4a39e 7832static struct type *
fc1a4b47 7833to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 7834 CORE_ADDR address, struct value *dval0)
14f9c5c9 7835{
d2e4a39e 7836 struct value *mark = value_mark ();
4c4b4cd2 7837 struct value *dval;
d2e4a39e 7838 struct type *rtype;
14f9c5c9
AS
7839 struct type *branch_type;
7840 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 7841 int variant_field = variant_field_index (type);
14f9c5c9 7842
4c4b4cd2 7843 if (variant_field == -1)
14f9c5c9
AS
7844 return type;
7845
4c4b4cd2
PH
7846 if (dval0 == NULL)
7847 dval = value_from_contents_and_address (type, valaddr, address);
7848 else
7849 dval = dval0;
7850
e9bb382b 7851 rtype = alloc_type_copy (type);
14f9c5c9 7852 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
7853 INIT_CPLUS_SPECIFIC (rtype);
7854 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
7855 TYPE_FIELDS (rtype) =
7856 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7857 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 7858 sizeof (struct field) * nfields);
14f9c5c9
AS
7859 TYPE_NAME (rtype) = ada_type_name (type);
7860 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7861 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
7862 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7863
4c4b4cd2
PH
7864 branch_type = to_fixed_variant_branch_type
7865 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 7866 cond_offset_host (valaddr,
4c4b4cd2
PH
7867 TYPE_FIELD_BITPOS (type, variant_field)
7868 / TARGET_CHAR_BIT),
d2e4a39e 7869 cond_offset_target (address,
4c4b4cd2
PH
7870 TYPE_FIELD_BITPOS (type, variant_field)
7871 / TARGET_CHAR_BIT), dval);
d2e4a39e 7872 if (branch_type == NULL)
14f9c5c9 7873 {
4c4b4cd2 7874 int f;
5b4ee69b 7875
4c4b4cd2
PH
7876 for (f = variant_field + 1; f < nfields; f += 1)
7877 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 7878 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
7879 }
7880 else
7881 {
4c4b4cd2
PH
7882 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7883 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7884 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 7885 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 7886 }
4c4b4cd2 7887 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 7888
4c4b4cd2 7889 value_free_to_mark (mark);
14f9c5c9
AS
7890 return rtype;
7891}
7892
7893/* An ordinary record type (with fixed-length fields) that describes
7894 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7895 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
7896 should be in DVAL, a record value; it may be NULL if the object
7897 at ADDR itself contains any necessary discriminant values.
7898 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7899 values from the record are needed. Except in the case that DVAL,
7900 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7901 unchecked) is replaced by a particular branch of the variant.
7902
7903 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7904 is questionable and may be removed. It can arise during the
7905 processing of an unconstrained-array-of-record type where all the
7906 variant branches have exactly the same size. This is because in
7907 such cases, the compiler does not bother to use the XVS convention
7908 when encoding the record. I am currently dubious of this
7909 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 7910
d2e4a39e 7911static struct type *
fc1a4b47 7912to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 7913 CORE_ADDR address, struct value *dval)
14f9c5c9 7914{
d2e4a39e 7915 struct type *templ_type;
14f9c5c9 7916
876cecd0 7917 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
7918 return type0;
7919
d2e4a39e 7920 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
7921
7922 if (templ_type != NULL)
7923 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
7924 else if (variant_field_index (type0) >= 0)
7925 {
7926 if (dval == NULL && valaddr == NULL && address == 0)
7927 return type0;
7928 return to_record_with_fixed_variant_part (type0, valaddr, address,
7929 dval);
7930 }
14f9c5c9
AS
7931 else
7932 {
876cecd0 7933 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
7934 return type0;
7935 }
7936
7937}
7938
7939/* An ordinary record type (with fixed-length fields) that describes
7940 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7941 union type. Any necessary discriminants' values should be in DVAL,
7942 a record value. That is, this routine selects the appropriate
7943 branch of the union at ADDR according to the discriminant value
b1f33ddd 7944 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 7945 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 7946
d2e4a39e 7947static struct type *
fc1a4b47 7948to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 7949 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
7950{
7951 int which;
d2e4a39e
AS
7952 struct type *templ_type;
7953 struct type *var_type;
14f9c5c9
AS
7954
7955 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
7956 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 7957 else
14f9c5c9
AS
7958 var_type = var_type0;
7959
7960 templ_type = ada_find_parallel_type (var_type, "___XVU");
7961
7962 if (templ_type != NULL)
7963 var_type = templ_type;
7964
b1f33ddd
JB
7965 if (is_unchecked_variant (var_type, value_type (dval)))
7966 return var_type0;
d2e4a39e
AS
7967 which =
7968 ada_which_variant_applies (var_type,
0fd88904 7969 value_type (dval), value_contents (dval));
14f9c5c9
AS
7970
7971 if (which < 0)
e9bb382b 7972 return empty_record (var_type);
14f9c5c9 7973 else if (is_dynamic_field (var_type, which))
4c4b4cd2 7974 return to_fixed_record_type
d2e4a39e
AS
7975 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
7976 valaddr, address, dval);
4c4b4cd2 7977 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
7978 return
7979 to_fixed_record_type
7980 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
7981 else
7982 return TYPE_FIELD_TYPE (var_type, which);
7983}
7984
7985/* Assuming that TYPE0 is an array type describing the type of a value
7986 at ADDR, and that DVAL describes a record containing any
7987 discriminants used in TYPE0, returns a type for the value that
7988 contains no dynamic components (that is, no components whose sizes
7989 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7990 true, gives an error message if the resulting type's size is over
4c4b4cd2 7991 varsize_limit. */
14f9c5c9 7992
d2e4a39e
AS
7993static struct type *
7994to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 7995 int ignore_too_big)
14f9c5c9 7996{
d2e4a39e
AS
7997 struct type *index_type_desc;
7998 struct type *result;
ad82864c 7999 int constrained_packed_array_p;
14f9c5c9 8000
b0dd7688 8001 type0 = ada_check_typedef (type0);
284614f0 8002 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8003 return type0;
14f9c5c9 8004
ad82864c
JB
8005 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8006 if (constrained_packed_array_p)
8007 type0 = decode_constrained_packed_array_type (type0);
284614f0 8008
14f9c5c9 8009 index_type_desc = ada_find_parallel_type (type0, "___XA");
28c85d6c 8010 ada_fixup_array_indexes_type (index_type_desc);
14f9c5c9
AS
8011 if (index_type_desc == NULL)
8012 {
61ee279c 8013 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8014
14f9c5c9 8015 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8016 depend on the contents of the array in properly constructed
8017 debugging data. */
529cad9c
PH
8018 /* Create a fixed version of the array element type.
8019 We're not providing the address of an element here,
e1d5a0d2 8020 and thus the actual object value cannot be inspected to do
529cad9c
PH
8021 the conversion. This should not be a problem, since arrays of
8022 unconstrained objects are not allowed. In particular, all
8023 the elements of an array of a tagged type should all be of
8024 the same type specified in the debugging info. No need to
8025 consult the object tag. */
1ed6ede0 8026 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8027
284614f0
JB
8028 /* Make sure we always create a new array type when dealing with
8029 packed array types, since we're going to fix-up the array
8030 type length and element bitsize a little further down. */
ad82864c 8031 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8032 result = type0;
14f9c5c9 8033 else
e9bb382b 8034 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8035 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8036 }
8037 else
8038 {
8039 int i;
8040 struct type *elt_type0;
8041
8042 elt_type0 = type0;
8043 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8044 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8045
8046 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8047 depend on the contents of the array in properly constructed
8048 debugging data. */
529cad9c
PH
8049 /* Create a fixed version of the array element type.
8050 We're not providing the address of an element here,
e1d5a0d2 8051 and thus the actual object value cannot be inspected to do
529cad9c
PH
8052 the conversion. This should not be a problem, since arrays of
8053 unconstrained objects are not allowed. In particular, all
8054 the elements of an array of a tagged type should all be of
8055 the same type specified in the debugging info. No need to
8056 consult the object tag. */
1ed6ede0
JB
8057 result =
8058 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8059
8060 elt_type0 = type0;
14f9c5c9 8061 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8062 {
8063 struct type *range_type =
28c85d6c 8064 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8065
e9bb382b 8066 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8067 result, range_type);
1ce677a4 8068 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8069 }
d2e4a39e 8070 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8071 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8072 }
8073
2e6fda7d
JB
8074 /* We want to preserve the type name. This can be useful when
8075 trying to get the type name of a value that has already been
8076 printed (for instance, if the user did "print VAR; whatis $". */
8077 TYPE_NAME (result) = TYPE_NAME (type0);
8078
ad82864c 8079 if (constrained_packed_array_p)
284614f0
JB
8080 {
8081 /* So far, the resulting type has been created as if the original
8082 type was a regular (non-packed) array type. As a result, the
8083 bitsize of the array elements needs to be set again, and the array
8084 length needs to be recomputed based on that bitsize. */
8085 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8086 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8087
8088 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8089 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8090 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8091 TYPE_LENGTH (result)++;
8092 }
8093
876cecd0 8094 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8095 return result;
d2e4a39e 8096}
14f9c5c9
AS
8097
8098
8099/* A standard type (containing no dynamically sized components)
8100 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8101 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8102 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8103 ADDRESS or in VALADDR contains these discriminants.
8104
1ed6ede0
JB
8105 If CHECK_TAG is not null, in the case of tagged types, this function
8106 attempts to locate the object's tag and use it to compute the actual
8107 type. However, when ADDRESS is null, we cannot use it to determine the
8108 location of the tag, and therefore compute the tagged type's actual type.
8109 So we return the tagged type without consulting the tag. */
529cad9c 8110
f192137b
JB
8111static struct type *
8112ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 8113 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 8114{
61ee279c 8115 type = ada_check_typedef (type);
d2e4a39e
AS
8116 switch (TYPE_CODE (type))
8117 {
8118 default:
14f9c5c9 8119 return type;
d2e4a39e 8120 case TYPE_CODE_STRUCT:
4c4b4cd2 8121 {
76a01679 8122 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
8123 struct type *fixed_record_type =
8124 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 8125
529cad9c
PH
8126 /* If STATIC_TYPE is a tagged type and we know the object's address,
8127 then we can determine its tag, and compute the object's actual
0963b4bd 8128 type from there. Note that we have to use the fixed record
1ed6ede0
JB
8129 type (the parent part of the record may have dynamic fields
8130 and the way the location of _tag is expressed may depend on
8131 them). */
529cad9c 8132
1ed6ede0 8133 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 8134 {
b50d69b5
JG
8135 struct value *tag =
8136 value_tag_from_contents_and_address
8137 (fixed_record_type,
8138 valaddr,
8139 address);
8140 struct type *real_type = type_from_tag (tag);
8141 struct value *obj =
8142 value_from_contents_and_address (fixed_record_type,
8143 valaddr,
8144 address);
76a01679 8145 if (real_type != NULL)
b50d69b5
JG
8146 return to_fixed_record_type
8147 (real_type, NULL,
8148 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 8149 }
4af88198
JB
8150
8151 /* Check to see if there is a parallel ___XVZ variable.
8152 If there is, then it provides the actual size of our type. */
8153 else if (ada_type_name (fixed_record_type) != NULL)
8154 {
0d5cff50 8155 const char *name = ada_type_name (fixed_record_type);
4af88198
JB
8156 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
8157 int xvz_found = 0;
8158 LONGEST size;
8159
88c15c34 8160 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
4af88198
JB
8161 size = get_int_var_value (xvz_name, &xvz_found);
8162 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8163 {
8164 fixed_record_type = copy_type (fixed_record_type);
8165 TYPE_LENGTH (fixed_record_type) = size;
8166
8167 /* The FIXED_RECORD_TYPE may have be a stub. We have
8168 observed this when the debugging info is STABS, and
8169 apparently it is something that is hard to fix.
8170
8171 In practice, we don't need the actual type definition
8172 at all, because the presence of the XVZ variable allows us
8173 to assume that there must be a XVS type as well, which we
8174 should be able to use later, when we need the actual type
8175 definition.
8176
8177 In the meantime, pretend that the "fixed" type we are
8178 returning is NOT a stub, because this can cause trouble
8179 when using this type to create new types targeting it.
8180 Indeed, the associated creation routines often check
8181 whether the target type is a stub and will try to replace
0963b4bd 8182 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
8183 might cause the new type to have the wrong size too.
8184 Consider the case of an array, for instance, where the size
8185 of the array is computed from the number of elements in
8186 our array multiplied by the size of its element. */
8187 TYPE_STUB (fixed_record_type) = 0;
8188 }
8189 }
1ed6ede0 8190 return fixed_record_type;
4c4b4cd2 8191 }
d2e4a39e 8192 case TYPE_CODE_ARRAY:
4c4b4cd2 8193 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
8194 case TYPE_CODE_UNION:
8195 if (dval == NULL)
4c4b4cd2 8196 return type;
d2e4a39e 8197 else
4c4b4cd2 8198 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 8199 }
14f9c5c9
AS
8200}
8201
f192137b
JB
8202/* The same as ada_to_fixed_type_1, except that it preserves the type
8203 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
8204
8205 The typedef layer needs be preserved in order to differentiate between
8206 arrays and array pointers when both types are implemented using the same
8207 fat pointer. In the array pointer case, the pointer is encoded as
8208 a typedef of the pointer type. For instance, considering:
8209
8210 type String_Access is access String;
8211 S1 : String_Access := null;
8212
8213 To the debugger, S1 is defined as a typedef of type String. But
8214 to the user, it is a pointer. So if the user tries to print S1,
8215 we should not dereference the array, but print the array address
8216 instead.
8217
8218 If we didn't preserve the typedef layer, we would lose the fact that
8219 the type is to be presented as a pointer (needs de-reference before
8220 being printed). And we would also use the source-level type name. */
f192137b
JB
8221
8222struct type *
8223ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8224 CORE_ADDR address, struct value *dval, int check_tag)
8225
8226{
8227 struct type *fixed_type =
8228 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8229
96dbd2c1
JB
8230 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8231 then preserve the typedef layer.
8232
8233 Implementation note: We can only check the main-type portion of
8234 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8235 from TYPE now returns a type that has the same instance flags
8236 as TYPE. For instance, if TYPE is a "typedef const", and its
8237 target type is a "struct", then the typedef elimination will return
8238 a "const" version of the target type. See check_typedef for more
8239 details about how the typedef layer elimination is done.
8240
8241 brobecker/2010-11-19: It seems to me that the only case where it is
8242 useful to preserve the typedef layer is when dealing with fat pointers.
8243 Perhaps, we could add a check for that and preserve the typedef layer
8244 only in that situation. But this seems unecessary so far, probably
8245 because we call check_typedef/ada_check_typedef pretty much everywhere.
8246 */
f192137b 8247 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 8248 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 8249 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
8250 return type;
8251
8252 return fixed_type;
8253}
8254
14f9c5c9 8255/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 8256 TYPE0, but based on no runtime data. */
14f9c5c9 8257
d2e4a39e
AS
8258static struct type *
8259to_static_fixed_type (struct type *type0)
14f9c5c9 8260{
d2e4a39e 8261 struct type *type;
14f9c5c9
AS
8262
8263 if (type0 == NULL)
8264 return NULL;
8265
876cecd0 8266 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8267 return type0;
8268
61ee279c 8269 type0 = ada_check_typedef (type0);
d2e4a39e 8270
14f9c5c9
AS
8271 switch (TYPE_CODE (type0))
8272 {
8273 default:
8274 return type0;
8275 case TYPE_CODE_STRUCT:
8276 type = dynamic_template_type (type0);
d2e4a39e 8277 if (type != NULL)
4c4b4cd2
PH
8278 return template_to_static_fixed_type (type);
8279 else
8280 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8281 case TYPE_CODE_UNION:
8282 type = ada_find_parallel_type (type0, "___XVU");
8283 if (type != NULL)
4c4b4cd2
PH
8284 return template_to_static_fixed_type (type);
8285 else
8286 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8287 }
8288}
8289
4c4b4cd2
PH
8290/* A static approximation of TYPE with all type wrappers removed. */
8291
d2e4a39e
AS
8292static struct type *
8293static_unwrap_type (struct type *type)
14f9c5c9
AS
8294{
8295 if (ada_is_aligner_type (type))
8296 {
61ee279c 8297 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 8298 if (ada_type_name (type1) == NULL)
4c4b4cd2 8299 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
8300
8301 return static_unwrap_type (type1);
8302 }
d2e4a39e 8303 else
14f9c5c9 8304 {
d2e4a39e 8305 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 8306
d2e4a39e 8307 if (raw_real_type == type)
4c4b4cd2 8308 return type;
14f9c5c9 8309 else
4c4b4cd2 8310 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
8311 }
8312}
8313
8314/* In some cases, incomplete and private types require
4c4b4cd2 8315 cross-references that are not resolved as records (for example,
14f9c5c9
AS
8316 type Foo;
8317 type FooP is access Foo;
8318 V: FooP;
8319 type Foo is array ...;
4c4b4cd2 8320 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
8321 cross-references to such types, we instead substitute for FooP a
8322 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 8323 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
8324
8325/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
8326 exists, otherwise TYPE. */
8327
d2e4a39e 8328struct type *
61ee279c 8329ada_check_typedef (struct type *type)
14f9c5c9 8330{
727e3d2e
JB
8331 if (type == NULL)
8332 return NULL;
8333
720d1a40
JB
8334 /* If our type is a typedef type of a fat pointer, then we're done.
8335 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8336 what allows us to distinguish between fat pointers that represent
8337 array types, and fat pointers that represent array access types
8338 (in both cases, the compiler implements them as fat pointers). */
8339 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8340 && is_thick_pntr (ada_typedef_target_type (type)))
8341 return type;
8342
14f9c5c9
AS
8343 CHECK_TYPEDEF (type);
8344 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 8345 || !TYPE_STUB (type)
14f9c5c9
AS
8346 || TYPE_TAG_NAME (type) == NULL)
8347 return type;
d2e4a39e 8348 else
14f9c5c9 8349 {
0d5cff50 8350 const char *name = TYPE_TAG_NAME (type);
d2e4a39e 8351 struct type *type1 = ada_find_any_type (name);
5b4ee69b 8352
05e522ef
JB
8353 if (type1 == NULL)
8354 return type;
8355
8356 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8357 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
8358 types, only for the typedef-to-array types). If that's the case,
8359 strip the typedef layer. */
8360 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
8361 type1 = ada_check_typedef (type1);
8362
8363 return type1;
14f9c5c9
AS
8364 }
8365}
8366
8367/* A value representing the data at VALADDR/ADDRESS as described by
8368 type TYPE0, but with a standard (static-sized) type that correctly
8369 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8370 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 8371 creation of struct values]. */
14f9c5c9 8372
4c4b4cd2
PH
8373static struct value *
8374ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8375 struct value *val0)
14f9c5c9 8376{
1ed6ede0 8377 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 8378
14f9c5c9
AS
8379 if (type == type0 && val0 != NULL)
8380 return val0;
d2e4a39e 8381 else
4c4b4cd2
PH
8382 return value_from_contents_and_address (type, 0, address);
8383}
8384
8385/* A value representing VAL, but with a standard (static-sized) type
8386 that correctly describes it. Does not necessarily create a new
8387 value. */
8388
0c3acc09 8389struct value *
4c4b4cd2
PH
8390ada_to_fixed_value (struct value *val)
8391{
c48db5ca
JB
8392 val = unwrap_value (val);
8393 val = ada_to_fixed_value_create (value_type (val),
8394 value_address (val),
8395 val);
8396 return val;
14f9c5c9 8397}
d2e4a39e 8398\f
14f9c5c9 8399
14f9c5c9
AS
8400/* Attributes */
8401
4c4b4cd2
PH
8402/* Table mapping attribute numbers to names.
8403 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 8404
d2e4a39e 8405static const char *attribute_names[] = {
14f9c5c9
AS
8406 "<?>",
8407
d2e4a39e 8408 "first",
14f9c5c9
AS
8409 "last",
8410 "length",
8411 "image",
14f9c5c9
AS
8412 "max",
8413 "min",
4c4b4cd2
PH
8414 "modulus",
8415 "pos",
8416 "size",
8417 "tag",
14f9c5c9 8418 "val",
14f9c5c9
AS
8419 0
8420};
8421
d2e4a39e 8422const char *
4c4b4cd2 8423ada_attribute_name (enum exp_opcode n)
14f9c5c9 8424{
4c4b4cd2
PH
8425 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8426 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
8427 else
8428 return attribute_names[0];
8429}
8430
4c4b4cd2 8431/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 8432
4c4b4cd2
PH
8433static LONGEST
8434pos_atr (struct value *arg)
14f9c5c9 8435{
24209737
PH
8436 struct value *val = coerce_ref (arg);
8437 struct type *type = value_type (val);
14f9c5c9 8438
d2e4a39e 8439 if (!discrete_type_p (type))
323e0a4a 8440 error (_("'POS only defined on discrete types"));
14f9c5c9
AS
8441
8442 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8443 {
8444 int i;
24209737 8445 LONGEST v = value_as_long (val);
14f9c5c9 8446
d2e4a39e 8447 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2 8448 {
14e75d8e 8449 if (v == TYPE_FIELD_ENUMVAL (type, i))
4c4b4cd2
PH
8450 return i;
8451 }
323e0a4a 8452 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9
AS
8453 }
8454 else
24209737 8455 return value_as_long (val);
4c4b4cd2
PH
8456}
8457
8458static struct value *
3cb382c9 8459value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 8460{
3cb382c9 8461 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
8462}
8463
4c4b4cd2 8464/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 8465
d2e4a39e
AS
8466static struct value *
8467value_val_atr (struct type *type, struct value *arg)
14f9c5c9 8468{
d2e4a39e 8469 if (!discrete_type_p (type))
323e0a4a 8470 error (_("'VAL only defined on discrete types"));
df407dfe 8471 if (!integer_type_p (value_type (arg)))
323e0a4a 8472 error (_("'VAL requires integral argument"));
14f9c5c9
AS
8473
8474 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8475 {
8476 long pos = value_as_long (arg);
5b4ee69b 8477
14f9c5c9 8478 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 8479 error (_("argument to 'VAL out of range"));
14e75d8e 8480 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
8481 }
8482 else
8483 return value_from_longest (type, value_as_long (arg));
8484}
14f9c5c9 8485\f
d2e4a39e 8486
4c4b4cd2 8487 /* Evaluation */
14f9c5c9 8488
4c4b4cd2
PH
8489/* True if TYPE appears to be an Ada character type.
8490 [At the moment, this is true only for Character and Wide_Character;
8491 It is a heuristic test that could stand improvement]. */
14f9c5c9 8492
d2e4a39e
AS
8493int
8494ada_is_character_type (struct type *type)
14f9c5c9 8495{
7b9f71f2
JB
8496 const char *name;
8497
8498 /* If the type code says it's a character, then assume it really is,
8499 and don't check any further. */
8500 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
8501 return 1;
8502
8503 /* Otherwise, assume it's a character type iff it is a discrete type
8504 with a known character type name. */
8505 name = ada_type_name (type);
8506 return (name != NULL
8507 && (TYPE_CODE (type) == TYPE_CODE_INT
8508 || TYPE_CODE (type) == TYPE_CODE_RANGE)
8509 && (strcmp (name, "character") == 0
8510 || strcmp (name, "wide_character") == 0
5a517ebd 8511 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 8512 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
8513}
8514
4c4b4cd2 8515/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
8516
8517int
ebf56fd3 8518ada_is_string_type (struct type *type)
14f9c5c9 8519{
61ee279c 8520 type = ada_check_typedef (type);
d2e4a39e 8521 if (type != NULL
14f9c5c9 8522 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
8523 && (ada_is_simple_array_type (type)
8524 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
8525 && ada_array_arity (type) == 1)
8526 {
8527 struct type *elttype = ada_array_element_type (type, 1);
8528
8529 return ada_is_character_type (elttype);
8530 }
d2e4a39e 8531 else
14f9c5c9
AS
8532 return 0;
8533}
8534
5bf03f13
JB
8535/* The compiler sometimes provides a parallel XVS type for a given
8536 PAD type. Normally, it is safe to follow the PAD type directly,
8537 but older versions of the compiler have a bug that causes the offset
8538 of its "F" field to be wrong. Following that field in that case
8539 would lead to incorrect results, but this can be worked around
8540 by ignoring the PAD type and using the associated XVS type instead.
8541
8542 Set to True if the debugger should trust the contents of PAD types.
8543 Otherwise, ignore the PAD type if there is a parallel XVS type. */
8544static int trust_pad_over_xvs = 1;
14f9c5c9
AS
8545
8546/* True if TYPE is a struct type introduced by the compiler to force the
8547 alignment of a value. Such types have a single field with a
4c4b4cd2 8548 distinctive name. */
14f9c5c9
AS
8549
8550int
ebf56fd3 8551ada_is_aligner_type (struct type *type)
14f9c5c9 8552{
61ee279c 8553 type = ada_check_typedef (type);
714e53ab 8554
5bf03f13 8555 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
8556 return 0;
8557
14f9c5c9 8558 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
8559 && TYPE_NFIELDS (type) == 1
8560 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
8561}
8562
8563/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 8564 the parallel type. */
14f9c5c9 8565
d2e4a39e
AS
8566struct type *
8567ada_get_base_type (struct type *raw_type)
14f9c5c9 8568{
d2e4a39e
AS
8569 struct type *real_type_namer;
8570 struct type *raw_real_type;
14f9c5c9
AS
8571
8572 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
8573 return raw_type;
8574
284614f0
JB
8575 if (ada_is_aligner_type (raw_type))
8576 /* The encoding specifies that we should always use the aligner type.
8577 So, even if this aligner type has an associated XVS type, we should
8578 simply ignore it.
8579
8580 According to the compiler gurus, an XVS type parallel to an aligner
8581 type may exist because of a stabs limitation. In stabs, aligner
8582 types are empty because the field has a variable-sized type, and
8583 thus cannot actually be used as an aligner type. As a result,
8584 we need the associated parallel XVS type to decode the type.
8585 Since the policy in the compiler is to not change the internal
8586 representation based on the debugging info format, we sometimes
8587 end up having a redundant XVS type parallel to the aligner type. */
8588 return raw_type;
8589
14f9c5c9 8590 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 8591 if (real_type_namer == NULL
14f9c5c9
AS
8592 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
8593 || TYPE_NFIELDS (real_type_namer) != 1)
8594 return raw_type;
8595
f80d3ff2
JB
8596 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
8597 {
8598 /* This is an older encoding form where the base type needs to be
8599 looked up by name. We prefer the newer enconding because it is
8600 more efficient. */
8601 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
8602 if (raw_real_type == NULL)
8603 return raw_type;
8604 else
8605 return raw_real_type;
8606 }
8607
8608 /* The field in our XVS type is a reference to the base type. */
8609 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 8610}
14f9c5c9 8611
4c4b4cd2 8612/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 8613
d2e4a39e
AS
8614struct type *
8615ada_aligned_type (struct type *type)
14f9c5c9
AS
8616{
8617 if (ada_is_aligner_type (type))
8618 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
8619 else
8620 return ada_get_base_type (type);
8621}
8622
8623
8624/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 8625 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 8626
fc1a4b47
AC
8627const gdb_byte *
8628ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 8629{
d2e4a39e 8630 if (ada_is_aligner_type (type))
14f9c5c9 8631 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
8632 valaddr +
8633 TYPE_FIELD_BITPOS (type,
8634 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
8635 else
8636 return valaddr;
8637}
8638
4c4b4cd2
PH
8639
8640
14f9c5c9 8641/* The printed representation of an enumeration literal with encoded
4c4b4cd2 8642 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
8643const char *
8644ada_enum_name (const char *name)
14f9c5c9 8645{
4c4b4cd2
PH
8646 static char *result;
8647 static size_t result_len = 0;
d2e4a39e 8648 char *tmp;
14f9c5c9 8649
4c4b4cd2
PH
8650 /* First, unqualify the enumeration name:
8651 1. Search for the last '.' character. If we find one, then skip
177b42fe 8652 all the preceding characters, the unqualified name starts
76a01679 8653 right after that dot.
4c4b4cd2 8654 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
8655 translates dots into "__". Search forward for double underscores,
8656 but stop searching when we hit an overloading suffix, which is
8657 of the form "__" followed by digits. */
4c4b4cd2 8658
c3e5cd34
PH
8659 tmp = strrchr (name, '.');
8660 if (tmp != NULL)
4c4b4cd2
PH
8661 name = tmp + 1;
8662 else
14f9c5c9 8663 {
4c4b4cd2
PH
8664 while ((tmp = strstr (name, "__")) != NULL)
8665 {
8666 if (isdigit (tmp[2]))
8667 break;
8668 else
8669 name = tmp + 2;
8670 }
14f9c5c9
AS
8671 }
8672
8673 if (name[0] == 'Q')
8674 {
14f9c5c9 8675 int v;
5b4ee69b 8676
14f9c5c9 8677 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
8678 {
8679 if (sscanf (name + 2, "%x", &v) != 1)
8680 return name;
8681 }
14f9c5c9 8682 else
4c4b4cd2 8683 return name;
14f9c5c9 8684
4c4b4cd2 8685 GROW_VECT (result, result_len, 16);
14f9c5c9 8686 if (isascii (v) && isprint (v))
88c15c34 8687 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 8688 else if (name[1] == 'U')
88c15c34 8689 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 8690 else
88c15c34 8691 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
8692
8693 return result;
8694 }
d2e4a39e 8695 else
4c4b4cd2 8696 {
c3e5cd34
PH
8697 tmp = strstr (name, "__");
8698 if (tmp == NULL)
8699 tmp = strstr (name, "$");
8700 if (tmp != NULL)
4c4b4cd2
PH
8701 {
8702 GROW_VECT (result, result_len, tmp - name + 1);
8703 strncpy (result, name, tmp - name);
8704 result[tmp - name] = '\0';
8705 return result;
8706 }
8707
8708 return name;
8709 }
14f9c5c9
AS
8710}
8711
14f9c5c9
AS
8712/* Evaluate the subexpression of EXP starting at *POS as for
8713 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 8714 expression. */
14f9c5c9 8715
d2e4a39e
AS
8716static struct value *
8717evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 8718{
4b27a620 8719 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
8720}
8721
8722/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 8723 value it wraps. */
14f9c5c9 8724
d2e4a39e
AS
8725static struct value *
8726unwrap_value (struct value *val)
14f9c5c9 8727{
df407dfe 8728 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 8729
14f9c5c9
AS
8730 if (ada_is_aligner_type (type))
8731 {
de4d072f 8732 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 8733 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 8734
14f9c5c9 8735 if (ada_type_name (val_type) == NULL)
4c4b4cd2 8736 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
8737
8738 return unwrap_value (v);
8739 }
d2e4a39e 8740 else
14f9c5c9 8741 {
d2e4a39e 8742 struct type *raw_real_type =
61ee279c 8743 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 8744
5bf03f13
JB
8745 /* If there is no parallel XVS or XVE type, then the value is
8746 already unwrapped. Return it without further modification. */
8747 if ((type == raw_real_type)
8748 && ada_find_parallel_type (type, "___XVE") == NULL)
8749 return val;
14f9c5c9 8750
d2e4a39e 8751 return
4c4b4cd2
PH
8752 coerce_unspec_val_to_type
8753 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 8754 value_address (val),
1ed6ede0 8755 NULL, 1));
14f9c5c9
AS
8756 }
8757}
d2e4a39e
AS
8758
8759static struct value *
8760cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
8761{
8762 LONGEST val;
8763
df407dfe 8764 if (type == value_type (arg))
14f9c5c9 8765 return arg;
df407dfe 8766 else if (ada_is_fixed_point_type (value_type (arg)))
d2e4a39e 8767 val = ada_float_to_fixed (type,
df407dfe 8768 ada_fixed_to_float (value_type (arg),
4c4b4cd2 8769 value_as_long (arg)));
d2e4a39e 8770 else
14f9c5c9 8771 {
a53b7a21 8772 DOUBLEST argd = value_as_double (arg);
5b4ee69b 8773
14f9c5c9
AS
8774 val = ada_float_to_fixed (type, argd);
8775 }
8776
8777 return value_from_longest (type, val);
8778}
8779
d2e4a39e 8780static struct value *
a53b7a21 8781cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 8782{
df407dfe 8783 DOUBLEST val = ada_fixed_to_float (value_type (arg),
4c4b4cd2 8784 value_as_long (arg));
5b4ee69b 8785
a53b7a21 8786 return value_from_double (type, val);
14f9c5c9
AS
8787}
8788
d99dcf51
JB
8789/* Given two array types T1 and T2, return nonzero iff both arrays
8790 contain the same number of elements. */
8791
8792static int
8793ada_same_array_size_p (struct type *t1, struct type *t2)
8794{
8795 LONGEST lo1, hi1, lo2, hi2;
8796
8797 /* Get the array bounds in order to verify that the size of
8798 the two arrays match. */
8799 if (!get_array_bounds (t1, &lo1, &hi1)
8800 || !get_array_bounds (t2, &lo2, &hi2))
8801 error (_("unable to determine array bounds"));
8802
8803 /* To make things easier for size comparison, normalize a bit
8804 the case of empty arrays by making sure that the difference
8805 between upper bound and lower bound is always -1. */
8806 if (lo1 > hi1)
8807 hi1 = lo1 - 1;
8808 if (lo2 > hi2)
8809 hi2 = lo2 - 1;
8810
8811 return (hi1 - lo1 == hi2 - lo2);
8812}
8813
8814/* Assuming that VAL is an array of integrals, and TYPE represents
8815 an array with the same number of elements, but with wider integral
8816 elements, return an array "casted" to TYPE. In practice, this
8817 means that the returned array is built by casting each element
8818 of the original array into TYPE's (wider) element type. */
8819
8820static struct value *
8821ada_promote_array_of_integrals (struct type *type, struct value *val)
8822{
8823 struct type *elt_type = TYPE_TARGET_TYPE (type);
8824 LONGEST lo, hi;
8825 struct value *res;
8826 LONGEST i;
8827
8828 /* Verify that both val and type are arrays of scalars, and
8829 that the size of val's elements is smaller than the size
8830 of type's element. */
8831 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
8832 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
8833 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
8834 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
8835 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
8836 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
8837
8838 if (!get_array_bounds (type, &lo, &hi))
8839 error (_("unable to determine array bounds"));
8840
8841 res = allocate_value (type);
8842
8843 /* Promote each array element. */
8844 for (i = 0; i < hi - lo + 1; i++)
8845 {
8846 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
8847
8848 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
8849 value_contents_all (elt), TYPE_LENGTH (elt_type));
8850 }
8851
8852 return res;
8853}
8854
4c4b4cd2
PH
8855/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8856 return the converted value. */
8857
d2e4a39e
AS
8858static struct value *
8859coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 8860{
df407dfe 8861 struct type *type2 = value_type (val);
5b4ee69b 8862
14f9c5c9
AS
8863 if (type == type2)
8864 return val;
8865
61ee279c
PH
8866 type2 = ada_check_typedef (type2);
8867 type = ada_check_typedef (type);
14f9c5c9 8868
d2e4a39e
AS
8869 if (TYPE_CODE (type2) == TYPE_CODE_PTR
8870 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
8871 {
8872 val = ada_value_ind (val);
df407dfe 8873 type2 = value_type (val);
14f9c5c9
AS
8874 }
8875
d2e4a39e 8876 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
8877 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
8878 {
d99dcf51
JB
8879 if (!ada_same_array_size_p (type, type2))
8880 error (_("cannot assign arrays of different length"));
8881
8882 if (is_integral_type (TYPE_TARGET_TYPE (type))
8883 && is_integral_type (TYPE_TARGET_TYPE (type2))
8884 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8885 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8886 {
8887 /* Allow implicit promotion of the array elements to
8888 a wider type. */
8889 return ada_promote_array_of_integrals (type, val);
8890 }
8891
8892 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8893 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 8894 error (_("Incompatible types in assignment"));
04624583 8895 deprecated_set_value_type (val, type);
14f9c5c9 8896 }
d2e4a39e 8897 return val;
14f9c5c9
AS
8898}
8899
4c4b4cd2
PH
8900static struct value *
8901ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
8902{
8903 struct value *val;
8904 struct type *type1, *type2;
8905 LONGEST v, v1, v2;
8906
994b9211
AC
8907 arg1 = coerce_ref (arg1);
8908 arg2 = coerce_ref (arg2);
18af8284
JB
8909 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
8910 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 8911
76a01679
JB
8912 if (TYPE_CODE (type1) != TYPE_CODE_INT
8913 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
8914 return value_binop (arg1, arg2, op);
8915
76a01679 8916 switch (op)
4c4b4cd2
PH
8917 {
8918 case BINOP_MOD:
8919 case BINOP_DIV:
8920 case BINOP_REM:
8921 break;
8922 default:
8923 return value_binop (arg1, arg2, op);
8924 }
8925
8926 v2 = value_as_long (arg2);
8927 if (v2 == 0)
323e0a4a 8928 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
8929
8930 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
8931 return value_binop (arg1, arg2, op);
8932
8933 v1 = value_as_long (arg1);
8934 switch (op)
8935 {
8936 case BINOP_DIV:
8937 v = v1 / v2;
76a01679
JB
8938 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
8939 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
8940 break;
8941 case BINOP_REM:
8942 v = v1 % v2;
76a01679
JB
8943 if (v * v1 < 0)
8944 v -= v2;
4c4b4cd2
PH
8945 break;
8946 default:
8947 /* Should not reach this point. */
8948 v = 0;
8949 }
8950
8951 val = allocate_value (type1);
990a07ab 8952 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
8953 TYPE_LENGTH (value_type (val)),
8954 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
8955 return val;
8956}
8957
8958static int
8959ada_value_equal (struct value *arg1, struct value *arg2)
8960{
df407dfe
AC
8961 if (ada_is_direct_array_type (value_type (arg1))
8962 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 8963 {
f58b38bf
JB
8964 /* Automatically dereference any array reference before
8965 we attempt to perform the comparison. */
8966 arg1 = ada_coerce_ref (arg1);
8967 arg2 = ada_coerce_ref (arg2);
8968
4c4b4cd2
PH
8969 arg1 = ada_coerce_to_simple_array (arg1);
8970 arg2 = ada_coerce_to_simple_array (arg2);
df407dfe
AC
8971 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
8972 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
323e0a4a 8973 error (_("Attempt to compare array with non-array"));
4c4b4cd2 8974 /* FIXME: The following works only for types whose
76a01679
JB
8975 representations use all bits (no padding or undefined bits)
8976 and do not have user-defined equality. */
8977 return
df407dfe 8978 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
0fd88904 8979 && memcmp (value_contents (arg1), value_contents (arg2),
df407dfe 8980 TYPE_LENGTH (value_type (arg1))) == 0;
4c4b4cd2
PH
8981 }
8982 return value_equal (arg1, arg2);
8983}
8984
52ce6436
PH
8985/* Total number of component associations in the aggregate starting at
8986 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 8987 OP_AGGREGATE. */
52ce6436
PH
8988
8989static int
8990num_component_specs (struct expression *exp, int pc)
8991{
8992 int n, m, i;
5b4ee69b 8993
52ce6436
PH
8994 m = exp->elts[pc + 1].longconst;
8995 pc += 3;
8996 n = 0;
8997 for (i = 0; i < m; i += 1)
8998 {
8999 switch (exp->elts[pc].opcode)
9000 {
9001 default:
9002 n += 1;
9003 break;
9004 case OP_CHOICES:
9005 n += exp->elts[pc + 1].longconst;
9006 break;
9007 }
9008 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9009 }
9010 return n;
9011}
9012
9013/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9014 component of LHS (a simple array or a record), updating *POS past
9015 the expression, assuming that LHS is contained in CONTAINER. Does
9016 not modify the inferior's memory, nor does it modify LHS (unless
9017 LHS == CONTAINER). */
9018
9019static void
9020assign_component (struct value *container, struct value *lhs, LONGEST index,
9021 struct expression *exp, int *pos)
9022{
9023 struct value *mark = value_mark ();
9024 struct value *elt;
5b4ee69b 9025
52ce6436
PH
9026 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
9027 {
22601c15
UW
9028 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9029 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9030
52ce6436
PH
9031 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9032 }
9033 else
9034 {
9035 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9036 elt = ada_to_fixed_value (elt);
52ce6436
PH
9037 }
9038
9039 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9040 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9041 else
9042 value_assign_to_component (container, elt,
9043 ada_evaluate_subexp (NULL, exp, pos,
9044 EVAL_NORMAL));
9045
9046 value_free_to_mark (mark);
9047}
9048
9049/* Assuming that LHS represents an lvalue having a record or array
9050 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9051 of that aggregate's value to LHS, advancing *POS past the
9052 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9053 lvalue containing LHS (possibly LHS itself). Does not modify
9054 the inferior's memory, nor does it modify the contents of
0963b4bd 9055 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9056
9057static struct value *
9058assign_aggregate (struct value *container,
9059 struct value *lhs, struct expression *exp,
9060 int *pos, enum noside noside)
9061{
9062 struct type *lhs_type;
9063 int n = exp->elts[*pos+1].longconst;
9064 LONGEST low_index, high_index;
9065 int num_specs;
9066 LONGEST *indices;
9067 int max_indices, num_indices;
52ce6436 9068 int i;
52ce6436
PH
9069
9070 *pos += 3;
9071 if (noside != EVAL_NORMAL)
9072 {
52ce6436
PH
9073 for (i = 0; i < n; i += 1)
9074 ada_evaluate_subexp (NULL, exp, pos, noside);
9075 return container;
9076 }
9077
9078 container = ada_coerce_ref (container);
9079 if (ada_is_direct_array_type (value_type (container)))
9080 container = ada_coerce_to_simple_array (container);
9081 lhs = ada_coerce_ref (lhs);
9082 if (!deprecated_value_modifiable (lhs))
9083 error (_("Left operand of assignment is not a modifiable lvalue."));
9084
9085 lhs_type = value_type (lhs);
9086 if (ada_is_direct_array_type (lhs_type))
9087 {
9088 lhs = ada_coerce_to_simple_array (lhs);
9089 lhs_type = value_type (lhs);
9090 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9091 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
9092 }
9093 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9094 {
9095 low_index = 0;
9096 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
9097 }
9098 else
9099 error (_("Left-hand side must be array or record."));
9100
9101 num_specs = num_component_specs (exp, *pos - 3);
9102 max_indices = 4 * num_specs + 4;
9103 indices = alloca (max_indices * sizeof (indices[0]));
9104 indices[0] = indices[1] = low_index - 1;
9105 indices[2] = indices[3] = high_index + 1;
9106 num_indices = 4;
9107
9108 for (i = 0; i < n; i += 1)
9109 {
9110 switch (exp->elts[*pos].opcode)
9111 {
1fbf5ada
JB
9112 case OP_CHOICES:
9113 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9114 &num_indices, max_indices,
9115 low_index, high_index);
9116 break;
9117 case OP_POSITIONAL:
9118 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
9119 &num_indices, max_indices,
9120 low_index, high_index);
1fbf5ada
JB
9121 break;
9122 case OP_OTHERS:
9123 if (i != n-1)
9124 error (_("Misplaced 'others' clause"));
9125 aggregate_assign_others (container, lhs, exp, pos, indices,
9126 num_indices, low_index, high_index);
9127 break;
9128 default:
9129 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
9130 }
9131 }
9132
9133 return container;
9134}
9135
9136/* Assign into the component of LHS indexed by the OP_POSITIONAL
9137 construct at *POS, updating *POS past the construct, given that
9138 the positions are relative to lower bound LOW, where HIGH is the
9139 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9140 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 9141 assign_aggregate. */
52ce6436
PH
9142static void
9143aggregate_assign_positional (struct value *container,
9144 struct value *lhs, struct expression *exp,
9145 int *pos, LONGEST *indices, int *num_indices,
9146 int max_indices, LONGEST low, LONGEST high)
9147{
9148 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9149
9150 if (ind - 1 == high)
e1d5a0d2 9151 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
9152 if (ind <= high)
9153 {
9154 add_component_interval (ind, ind, indices, num_indices, max_indices);
9155 *pos += 3;
9156 assign_component (container, lhs, ind, exp, pos);
9157 }
9158 else
9159 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9160}
9161
9162/* Assign into the components of LHS indexed by the OP_CHOICES
9163 construct at *POS, updating *POS past the construct, given that
9164 the allowable indices are LOW..HIGH. Record the indices assigned
9165 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 9166 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9167static void
9168aggregate_assign_from_choices (struct value *container,
9169 struct value *lhs, struct expression *exp,
9170 int *pos, LONGEST *indices, int *num_indices,
9171 int max_indices, LONGEST low, LONGEST high)
9172{
9173 int j;
9174 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9175 int choice_pos, expr_pc;
9176 int is_array = ada_is_direct_array_type (value_type (lhs));
9177
9178 choice_pos = *pos += 3;
9179
9180 for (j = 0; j < n_choices; j += 1)
9181 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9182 expr_pc = *pos;
9183 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9184
9185 for (j = 0; j < n_choices; j += 1)
9186 {
9187 LONGEST lower, upper;
9188 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 9189
52ce6436
PH
9190 if (op == OP_DISCRETE_RANGE)
9191 {
9192 choice_pos += 1;
9193 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9194 EVAL_NORMAL));
9195 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9196 EVAL_NORMAL));
9197 }
9198 else if (is_array)
9199 {
9200 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9201 EVAL_NORMAL));
9202 upper = lower;
9203 }
9204 else
9205 {
9206 int ind;
0d5cff50 9207 const char *name;
5b4ee69b 9208
52ce6436
PH
9209 switch (op)
9210 {
9211 case OP_NAME:
9212 name = &exp->elts[choice_pos + 2].string;
9213 break;
9214 case OP_VAR_VALUE:
9215 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9216 break;
9217 default:
9218 error (_("Invalid record component association."));
9219 }
9220 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9221 ind = 0;
9222 if (! find_struct_field (name, value_type (lhs), 0,
9223 NULL, NULL, NULL, NULL, &ind))
9224 error (_("Unknown component name: %s."), name);
9225 lower = upper = ind;
9226 }
9227
9228 if (lower <= upper && (lower < low || upper > high))
9229 error (_("Index in component association out of bounds."));
9230
9231 add_component_interval (lower, upper, indices, num_indices,
9232 max_indices);
9233 while (lower <= upper)
9234 {
9235 int pos1;
5b4ee69b 9236
52ce6436
PH
9237 pos1 = expr_pc;
9238 assign_component (container, lhs, lower, exp, &pos1);
9239 lower += 1;
9240 }
9241 }
9242}
9243
9244/* Assign the value of the expression in the OP_OTHERS construct in
9245 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9246 have not been previously assigned. The index intervals already assigned
9247 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 9248 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9249static void
9250aggregate_assign_others (struct value *container,
9251 struct value *lhs, struct expression *exp,
9252 int *pos, LONGEST *indices, int num_indices,
9253 LONGEST low, LONGEST high)
9254{
9255 int i;
5ce64950 9256 int expr_pc = *pos + 1;
52ce6436
PH
9257
9258 for (i = 0; i < num_indices - 2; i += 2)
9259 {
9260 LONGEST ind;
5b4ee69b 9261
52ce6436
PH
9262 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9263 {
5ce64950 9264 int localpos;
5b4ee69b 9265
5ce64950
MS
9266 localpos = expr_pc;
9267 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
9268 }
9269 }
9270 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9271}
9272
9273/* Add the interval [LOW .. HIGH] to the sorted set of intervals
9274 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9275 modifying *SIZE as needed. It is an error if *SIZE exceeds
9276 MAX_SIZE. The resulting intervals do not overlap. */
9277static void
9278add_component_interval (LONGEST low, LONGEST high,
9279 LONGEST* indices, int *size, int max_size)
9280{
9281 int i, j;
5b4ee69b 9282
52ce6436
PH
9283 for (i = 0; i < *size; i += 2) {
9284 if (high >= indices[i] && low <= indices[i + 1])
9285 {
9286 int kh;
5b4ee69b 9287
52ce6436
PH
9288 for (kh = i + 2; kh < *size; kh += 2)
9289 if (high < indices[kh])
9290 break;
9291 if (low < indices[i])
9292 indices[i] = low;
9293 indices[i + 1] = indices[kh - 1];
9294 if (high > indices[i + 1])
9295 indices[i + 1] = high;
9296 memcpy (indices + i + 2, indices + kh, *size - kh);
9297 *size -= kh - i - 2;
9298 return;
9299 }
9300 else if (high < indices[i])
9301 break;
9302 }
9303
9304 if (*size == max_size)
9305 error (_("Internal error: miscounted aggregate components."));
9306 *size += 2;
9307 for (j = *size-1; j >= i+2; j -= 1)
9308 indices[j] = indices[j - 2];
9309 indices[i] = low;
9310 indices[i + 1] = high;
9311}
9312
6e48bd2c
JB
9313/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9314 is different. */
9315
9316static struct value *
9317ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
9318{
9319 if (type == ada_check_typedef (value_type (arg2)))
9320 return arg2;
9321
9322 if (ada_is_fixed_point_type (type))
9323 return (cast_to_fixed (type, arg2));
9324
9325 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9326 return cast_from_fixed (type, arg2);
6e48bd2c
JB
9327
9328 return value_cast (type, arg2);
9329}
9330
284614f0
JB
9331/* Evaluating Ada expressions, and printing their result.
9332 ------------------------------------------------------
9333
21649b50
JB
9334 1. Introduction:
9335 ----------------
9336
284614f0
JB
9337 We usually evaluate an Ada expression in order to print its value.
9338 We also evaluate an expression in order to print its type, which
9339 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9340 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9341 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9342 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9343 similar.
9344
9345 Evaluating expressions is a little more complicated for Ada entities
9346 than it is for entities in languages such as C. The main reason for
9347 this is that Ada provides types whose definition might be dynamic.
9348 One example of such types is variant records. Or another example
9349 would be an array whose bounds can only be known at run time.
9350
9351 The following description is a general guide as to what should be
9352 done (and what should NOT be done) in order to evaluate an expression
9353 involving such types, and when. This does not cover how the semantic
9354 information is encoded by GNAT as this is covered separatly. For the
9355 document used as the reference for the GNAT encoding, see exp_dbug.ads
9356 in the GNAT sources.
9357
9358 Ideally, we should embed each part of this description next to its
9359 associated code. Unfortunately, the amount of code is so vast right
9360 now that it's hard to see whether the code handling a particular
9361 situation might be duplicated or not. One day, when the code is
9362 cleaned up, this guide might become redundant with the comments
9363 inserted in the code, and we might want to remove it.
9364
21649b50
JB
9365 2. ``Fixing'' an Entity, the Simple Case:
9366 -----------------------------------------
9367
284614f0
JB
9368 When evaluating Ada expressions, the tricky issue is that they may
9369 reference entities whose type contents and size are not statically
9370 known. Consider for instance a variant record:
9371
9372 type Rec (Empty : Boolean := True) is record
9373 case Empty is
9374 when True => null;
9375 when False => Value : Integer;
9376 end case;
9377 end record;
9378 Yes : Rec := (Empty => False, Value => 1);
9379 No : Rec := (empty => True);
9380
9381 The size and contents of that record depends on the value of the
9382 descriminant (Rec.Empty). At this point, neither the debugging
9383 information nor the associated type structure in GDB are able to
9384 express such dynamic types. So what the debugger does is to create
9385 "fixed" versions of the type that applies to the specific object.
9386 We also informally refer to this opperation as "fixing" an object,
9387 which means creating its associated fixed type.
9388
9389 Example: when printing the value of variable "Yes" above, its fixed
9390 type would look like this:
9391
9392 type Rec is record
9393 Empty : Boolean;
9394 Value : Integer;
9395 end record;
9396
9397 On the other hand, if we printed the value of "No", its fixed type
9398 would become:
9399
9400 type Rec is record
9401 Empty : Boolean;
9402 end record;
9403
9404 Things become a little more complicated when trying to fix an entity
9405 with a dynamic type that directly contains another dynamic type,
9406 such as an array of variant records, for instance. There are
9407 two possible cases: Arrays, and records.
9408
21649b50
JB
9409 3. ``Fixing'' Arrays:
9410 ---------------------
9411
9412 The type structure in GDB describes an array in terms of its bounds,
9413 and the type of its elements. By design, all elements in the array
9414 have the same type and we cannot represent an array of variant elements
9415 using the current type structure in GDB. When fixing an array,
9416 we cannot fix the array element, as we would potentially need one
9417 fixed type per element of the array. As a result, the best we can do
9418 when fixing an array is to produce an array whose bounds and size
9419 are correct (allowing us to read it from memory), but without having
9420 touched its element type. Fixing each element will be done later,
9421 when (if) necessary.
9422
9423 Arrays are a little simpler to handle than records, because the same
9424 amount of memory is allocated for each element of the array, even if
1b536f04 9425 the amount of space actually used by each element differs from element
21649b50 9426 to element. Consider for instance the following array of type Rec:
284614f0
JB
9427
9428 type Rec_Array is array (1 .. 2) of Rec;
9429
1b536f04
JB
9430 The actual amount of memory occupied by each element might be different
9431 from element to element, depending on the value of their discriminant.
21649b50 9432 But the amount of space reserved for each element in the array remains
1b536f04 9433 fixed regardless. So we simply need to compute that size using
21649b50
JB
9434 the debugging information available, from which we can then determine
9435 the array size (we multiply the number of elements of the array by
9436 the size of each element).
9437
9438 The simplest case is when we have an array of a constrained element
9439 type. For instance, consider the following type declarations:
9440
9441 type Bounded_String (Max_Size : Integer) is
9442 Length : Integer;
9443 Buffer : String (1 .. Max_Size);
9444 end record;
9445 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9446
9447 In this case, the compiler describes the array as an array of
9448 variable-size elements (identified by its XVS suffix) for which
9449 the size can be read in the parallel XVZ variable.
9450
9451 In the case of an array of an unconstrained element type, the compiler
9452 wraps the array element inside a private PAD type. This type should not
9453 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
9454 that we also use the adjective "aligner" in our code to designate
9455 these wrapper types.
9456
1b536f04 9457 In some cases, the size allocated for each element is statically
21649b50
JB
9458 known. In that case, the PAD type already has the correct size,
9459 and the array element should remain unfixed.
9460
9461 But there are cases when this size is not statically known.
9462 For instance, assuming that "Five" is an integer variable:
284614f0
JB
9463
9464 type Dynamic is array (1 .. Five) of Integer;
9465 type Wrapper (Has_Length : Boolean := False) is record
9466 Data : Dynamic;
9467 case Has_Length is
9468 when True => Length : Integer;
9469 when False => null;
9470 end case;
9471 end record;
9472 type Wrapper_Array is array (1 .. 2) of Wrapper;
9473
9474 Hello : Wrapper_Array := (others => (Has_Length => True,
9475 Data => (others => 17),
9476 Length => 1));
9477
9478
9479 The debugging info would describe variable Hello as being an
9480 array of a PAD type. The size of that PAD type is not statically
9481 known, but can be determined using a parallel XVZ variable.
9482 In that case, a copy of the PAD type with the correct size should
9483 be used for the fixed array.
9484
21649b50
JB
9485 3. ``Fixing'' record type objects:
9486 ----------------------------------
9487
9488 Things are slightly different from arrays in the case of dynamic
284614f0
JB
9489 record types. In this case, in order to compute the associated
9490 fixed type, we need to determine the size and offset of each of
9491 its components. This, in turn, requires us to compute the fixed
9492 type of each of these components.
9493
9494 Consider for instance the example:
9495
9496 type Bounded_String (Max_Size : Natural) is record
9497 Str : String (1 .. Max_Size);
9498 Length : Natural;
9499 end record;
9500 My_String : Bounded_String (Max_Size => 10);
9501
9502 In that case, the position of field "Length" depends on the size
9503 of field Str, which itself depends on the value of the Max_Size
21649b50 9504 discriminant. In order to fix the type of variable My_String,
284614f0
JB
9505 we need to fix the type of field Str. Therefore, fixing a variant
9506 record requires us to fix each of its components.
9507
9508 However, if a component does not have a dynamic size, the component
9509 should not be fixed. In particular, fields that use a PAD type
9510 should not fixed. Here is an example where this might happen
9511 (assuming type Rec above):
9512
9513 type Container (Big : Boolean) is record
9514 First : Rec;
9515 After : Integer;
9516 case Big is
9517 when True => Another : Integer;
9518 when False => null;
9519 end case;
9520 end record;
9521 My_Container : Container := (Big => False,
9522 First => (Empty => True),
9523 After => 42);
9524
9525 In that example, the compiler creates a PAD type for component First,
9526 whose size is constant, and then positions the component After just
9527 right after it. The offset of component After is therefore constant
9528 in this case.
9529
9530 The debugger computes the position of each field based on an algorithm
9531 that uses, among other things, the actual position and size of the field
21649b50
JB
9532 preceding it. Let's now imagine that the user is trying to print
9533 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
9534 end up computing the offset of field After based on the size of the
9535 fixed version of field First. And since in our example First has
9536 only one actual field, the size of the fixed type is actually smaller
9537 than the amount of space allocated to that field, and thus we would
9538 compute the wrong offset of field After.
9539
21649b50
JB
9540 To make things more complicated, we need to watch out for dynamic
9541 components of variant records (identified by the ___XVL suffix in
9542 the component name). Even if the target type is a PAD type, the size
9543 of that type might not be statically known. So the PAD type needs
9544 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9545 we might end up with the wrong size for our component. This can be
9546 observed with the following type declarations:
284614f0
JB
9547
9548 type Octal is new Integer range 0 .. 7;
9549 type Octal_Array is array (Positive range <>) of Octal;
9550 pragma Pack (Octal_Array);
9551
9552 type Octal_Buffer (Size : Positive) is record
9553 Buffer : Octal_Array (1 .. Size);
9554 Length : Integer;
9555 end record;
9556
9557 In that case, Buffer is a PAD type whose size is unset and needs
9558 to be computed by fixing the unwrapped type.
9559
21649b50
JB
9560 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9561 ----------------------------------------------------------
9562
9563 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
9564 thus far, be actually fixed?
9565
9566 The answer is: Only when referencing that element. For instance
9567 when selecting one component of a record, this specific component
9568 should be fixed at that point in time. Or when printing the value
9569 of a record, each component should be fixed before its value gets
9570 printed. Similarly for arrays, the element of the array should be
9571 fixed when printing each element of the array, or when extracting
9572 one element out of that array. On the other hand, fixing should
9573 not be performed on the elements when taking a slice of an array!
9574
9575 Note that one of the side-effects of miscomputing the offset and
9576 size of each field is that we end up also miscomputing the size
9577 of the containing type. This can have adverse results when computing
9578 the value of an entity. GDB fetches the value of an entity based
9579 on the size of its type, and thus a wrong size causes GDB to fetch
9580 the wrong amount of memory. In the case where the computed size is
9581 too small, GDB fetches too little data to print the value of our
9582 entiry. Results in this case as unpredicatble, as we usually read
9583 past the buffer containing the data =:-o. */
9584
9585/* Implement the evaluate_exp routine in the exp_descriptor structure
9586 for the Ada language. */
9587
52ce6436 9588static struct value *
ebf56fd3 9589ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 9590 int *pos, enum noside noside)
14f9c5c9
AS
9591{
9592 enum exp_opcode op;
b5385fc0 9593 int tem;
14f9c5c9
AS
9594 int pc;
9595 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
9596 struct type *type;
52ce6436 9597 int nargs, oplen;
d2e4a39e 9598 struct value **argvec;
14f9c5c9 9599
d2e4a39e
AS
9600 pc = *pos;
9601 *pos += 1;
14f9c5c9
AS
9602 op = exp->elts[pc].opcode;
9603
d2e4a39e 9604 switch (op)
14f9c5c9
AS
9605 {
9606 default:
9607 *pos -= 1;
6e48bd2c 9608 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
9609
9610 if (noside == EVAL_NORMAL)
9611 arg1 = unwrap_value (arg1);
6e48bd2c
JB
9612
9613 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
9614 then we need to perform the conversion manually, because
9615 evaluate_subexp_standard doesn't do it. This conversion is
9616 necessary in Ada because the different kinds of float/fixed
9617 types in Ada have different representations.
9618
9619 Similarly, we need to perform the conversion from OP_LONG
9620 ourselves. */
9621 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
9622 arg1 = ada_value_cast (expect_type, arg1, noside);
9623
9624 return arg1;
4c4b4cd2
PH
9625
9626 case OP_STRING:
9627 {
76a01679 9628 struct value *result;
5b4ee69b 9629
76a01679
JB
9630 *pos -= 1;
9631 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
9632 /* The result type will have code OP_STRING, bashed there from
9633 OP_ARRAY. Bash it back. */
df407dfe
AC
9634 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
9635 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 9636 return result;
4c4b4cd2 9637 }
14f9c5c9
AS
9638
9639 case UNOP_CAST:
9640 (*pos) += 2;
9641 type = exp->elts[pc + 1].type;
9642 arg1 = evaluate_subexp (type, exp, pos, noside);
9643 if (noside == EVAL_SKIP)
4c4b4cd2 9644 goto nosideret;
6e48bd2c 9645 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
9646 return arg1;
9647
4c4b4cd2
PH
9648 case UNOP_QUAL:
9649 (*pos) += 2;
9650 type = exp->elts[pc + 1].type;
9651 return ada_evaluate_subexp (type, exp, pos, noside);
9652
14f9c5c9
AS
9653 case BINOP_ASSIGN:
9654 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
9655 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9656 {
9657 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
9658 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
9659 return arg1;
9660 return ada_value_assign (arg1, arg1);
9661 }
003f3813
JB
9662 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9663 except if the lhs of our assignment is a convenience variable.
9664 In the case of assigning to a convenience variable, the lhs
9665 should be exactly the result of the evaluation of the rhs. */
9666 type = value_type (arg1);
9667 if (VALUE_LVAL (arg1) == lval_internalvar)
9668 type = NULL;
9669 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 9670 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 9671 return arg1;
df407dfe
AC
9672 if (ada_is_fixed_point_type (value_type (arg1)))
9673 arg2 = cast_to_fixed (value_type (arg1), arg2);
9674 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 9675 error
323e0a4a 9676 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 9677 else
df407dfe 9678 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 9679 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
9680
9681 case BINOP_ADD:
9682 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9683 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9684 if (noside == EVAL_SKIP)
4c4b4cd2 9685 goto nosideret;
2ac8a782
JB
9686 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9687 return (value_from_longest
9688 (value_type (arg1),
9689 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
9690 if ((ada_is_fixed_point_type (value_type (arg1))
9691 || ada_is_fixed_point_type (value_type (arg2)))
9692 && value_type (arg1) != value_type (arg2))
323e0a4a 9693 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
9694 /* Do the addition, and cast the result to the type of the first
9695 argument. We cannot cast the result to a reference type, so if
9696 ARG1 is a reference type, find its underlying type. */
9697 type = value_type (arg1);
9698 while (TYPE_CODE (type) == TYPE_CODE_REF)
9699 type = TYPE_TARGET_TYPE (type);
f44316fa 9700 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 9701 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
9702
9703 case BINOP_SUB:
9704 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9705 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9706 if (noside == EVAL_SKIP)
4c4b4cd2 9707 goto nosideret;
2ac8a782
JB
9708 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9709 return (value_from_longest
9710 (value_type (arg1),
9711 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
9712 if ((ada_is_fixed_point_type (value_type (arg1))
9713 || ada_is_fixed_point_type (value_type (arg2)))
9714 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
9715 error (_("Operands of fixed-point subtraction "
9716 "must have the same type"));
b7789565
JB
9717 /* Do the substraction, and cast the result to the type of the first
9718 argument. We cannot cast the result to a reference type, so if
9719 ARG1 is a reference type, find its underlying type. */
9720 type = value_type (arg1);
9721 while (TYPE_CODE (type) == TYPE_CODE_REF)
9722 type = TYPE_TARGET_TYPE (type);
f44316fa 9723 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 9724 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
9725
9726 case BINOP_MUL:
9727 case BINOP_DIV:
e1578042
JB
9728 case BINOP_REM:
9729 case BINOP_MOD:
14f9c5c9
AS
9730 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9731 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9732 if (noside == EVAL_SKIP)
4c4b4cd2 9733 goto nosideret;
e1578042 9734 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
9735 {
9736 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9737 return value_zero (value_type (arg1), not_lval);
9738 }
14f9c5c9 9739 else
4c4b4cd2 9740 {
a53b7a21 9741 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 9742 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 9743 arg1 = cast_from_fixed (type, arg1);
df407dfe 9744 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9745 arg2 = cast_from_fixed (type, arg2);
f44316fa 9746 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
9747 return ada_value_binop (arg1, arg2, op);
9748 }
9749
4c4b4cd2
PH
9750 case BINOP_EQUAL:
9751 case BINOP_NOTEQUAL:
14f9c5c9 9752 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 9753 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 9754 if (noside == EVAL_SKIP)
76a01679 9755 goto nosideret;
4c4b4cd2 9756 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9757 tem = 0;
4c4b4cd2 9758 else
f44316fa
UW
9759 {
9760 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9761 tem = ada_value_equal (arg1, arg2);
9762 }
4c4b4cd2 9763 if (op == BINOP_NOTEQUAL)
76a01679 9764 tem = !tem;
fbb06eb1
UW
9765 type = language_bool_type (exp->language_defn, exp->gdbarch);
9766 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
9767
9768 case UNOP_NEG:
9769 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9770 if (noside == EVAL_SKIP)
9771 goto nosideret;
df407dfe
AC
9772 else if (ada_is_fixed_point_type (value_type (arg1)))
9773 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 9774 else
f44316fa
UW
9775 {
9776 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9777 return value_neg (arg1);
9778 }
4c4b4cd2 9779
2330c6c6
JB
9780 case BINOP_LOGICAL_AND:
9781 case BINOP_LOGICAL_OR:
9782 case UNOP_LOGICAL_NOT:
000d5124
JB
9783 {
9784 struct value *val;
9785
9786 *pos -= 1;
9787 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
9788 type = language_bool_type (exp->language_defn, exp->gdbarch);
9789 return value_cast (type, val);
000d5124 9790 }
2330c6c6
JB
9791
9792 case BINOP_BITWISE_AND:
9793 case BINOP_BITWISE_IOR:
9794 case BINOP_BITWISE_XOR:
000d5124
JB
9795 {
9796 struct value *val;
9797
9798 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
9799 *pos = pc;
9800 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
9801
9802 return value_cast (value_type (arg1), val);
9803 }
2330c6c6 9804
14f9c5c9
AS
9805 case OP_VAR_VALUE:
9806 *pos -= 1;
6799def4 9807
14f9c5c9 9808 if (noside == EVAL_SKIP)
4c4b4cd2
PH
9809 {
9810 *pos += 4;
9811 goto nosideret;
9812 }
9813 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
9814 /* Only encountered when an unresolved symbol occurs in a
9815 context other than a function call, in which case, it is
52ce6436 9816 invalid. */
323e0a4a 9817 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 9818 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
14f9c5c9 9819 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 9820 {
0c1f74cf 9821 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
9822 /* Check to see if this is a tagged type. We also need to handle
9823 the case where the type is a reference to a tagged type, but
9824 we have to be careful to exclude pointers to tagged types.
9825 The latter should be shown as usual (as a pointer), whereas
9826 a reference should mostly be transparent to the user. */
9827 if (ada_is_tagged_type (type, 0)
9828 || (TYPE_CODE(type) == TYPE_CODE_REF
9829 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0c1f74cf
JB
9830 {
9831 /* Tagged types are a little special in the fact that the real
9832 type is dynamic and can only be determined by inspecting the
9833 object's tag. This means that we need to get the object's
9834 value first (EVAL_NORMAL) and then extract the actual object
9835 type from its tag.
9836
9837 Note that we cannot skip the final step where we extract
9838 the object type from its tag, because the EVAL_NORMAL phase
9839 results in dynamic components being resolved into fixed ones.
9840 This can cause problems when trying to print the type
9841 description of tagged types whose parent has a dynamic size:
9842 We use the type name of the "_parent" component in order
9843 to print the name of the ancestor type in the type description.
9844 If that component had a dynamic size, the resolution into
9845 a fixed type would result in the loss of that type name,
9846 thus preventing us from printing the name of the ancestor
9847 type in the type description. */
9848 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
b50d69b5
JG
9849
9850 if (TYPE_CODE (type) != TYPE_CODE_REF)
9851 {
9852 struct type *actual_type;
9853
9854 actual_type = type_from_tag (ada_value_tag (arg1));
9855 if (actual_type == NULL)
9856 /* If, for some reason, we were unable to determine
9857 the actual type from the tag, then use the static
9858 approximation that we just computed as a fallback.
9859 This can happen if the debugging information is
9860 incomplete, for instance. */
9861 actual_type = type;
9862 return value_zero (actual_type, not_lval);
9863 }
9864 else
9865 {
9866 /* In the case of a ref, ada_coerce_ref takes care
9867 of determining the actual type. But the evaluation
9868 should return a ref as it should be valid to ask
9869 for its address; so rebuild a ref after coerce. */
9870 arg1 = ada_coerce_ref (arg1);
9871 return value_ref (arg1);
9872 }
0c1f74cf
JB
9873 }
9874
4c4b4cd2
PH
9875 *pos += 4;
9876 return value_zero
9877 (to_static_fixed_type
9878 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
9879 not_lval);
9880 }
d2e4a39e 9881 else
4c4b4cd2 9882 {
284614f0 9883 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
4c4b4cd2
PH
9884 return ada_to_fixed_value (arg1);
9885 }
9886
9887 case OP_FUNCALL:
9888 (*pos) += 2;
9889
9890 /* Allocate arg vector, including space for the function to be
9891 called in argvec[0] and a terminating NULL. */
9892 nargs = longest_to_int (exp->elts[pc + 1].longconst);
9893 argvec =
9894 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
9895
9896 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 9897 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 9898 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
9899 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
9900 else
9901 {
9902 for (tem = 0; tem <= nargs; tem += 1)
9903 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9904 argvec[tem] = 0;
9905
9906 if (noside == EVAL_SKIP)
9907 goto nosideret;
9908 }
9909
ad82864c
JB
9910 if (ada_is_constrained_packed_array_type
9911 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 9912 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
9913 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
9914 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
9915 /* This is a packed array that has already been fixed, and
9916 therefore already coerced to a simple array. Nothing further
9917 to do. */
9918 ;
df407dfe
AC
9919 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
9920 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
76a01679 9921 && VALUE_LVAL (argvec[0]) == lval_memory))
4c4b4cd2
PH
9922 argvec[0] = value_addr (argvec[0]);
9923
df407dfe 9924 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
9925
9926 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
9927 them. So, if this is an array typedef (encoding use for array
9928 access types encoded as fat pointers), strip it now. */
720d1a40
JB
9929 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
9930 type = ada_typedef_target_type (type);
9931
4c4b4cd2
PH
9932 if (TYPE_CODE (type) == TYPE_CODE_PTR)
9933 {
61ee279c 9934 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
9935 {
9936 case TYPE_CODE_FUNC:
61ee279c 9937 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
9938 break;
9939 case TYPE_CODE_ARRAY:
9940 break;
9941 case TYPE_CODE_STRUCT:
9942 if (noside != EVAL_AVOID_SIDE_EFFECTS)
9943 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 9944 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
9945 break;
9946 default:
323e0a4a 9947 error (_("cannot subscript or call something of type `%s'"),
df407dfe 9948 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
9949 break;
9950 }
9951 }
9952
9953 switch (TYPE_CODE (type))
9954 {
9955 case TYPE_CODE_FUNC:
9956 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972
PH
9957 {
9958 struct type *rtype = TYPE_TARGET_TYPE (type);
9959
9960 if (TYPE_GNU_IFUNC (type))
9961 return allocate_value (TYPE_TARGET_TYPE (rtype));
9962 return allocate_value (rtype);
9963 }
4c4b4cd2 9964 return call_function_by_hand (argvec[0], nargs, argvec + 1);
c8ea1972
PH
9965 case TYPE_CODE_INTERNAL_FUNCTION:
9966 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9967 /* We don't know anything about what the internal
9968 function might return, but we have to return
9969 something. */
9970 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
9971 not_lval);
9972 else
9973 return call_internal_function (exp->gdbarch, exp->language_defn,
9974 argvec[0], nargs, argvec + 1);
9975
4c4b4cd2
PH
9976 case TYPE_CODE_STRUCT:
9977 {
9978 int arity;
9979
4c4b4cd2
PH
9980 arity = ada_array_arity (type);
9981 type = ada_array_element_type (type, nargs);
9982 if (type == NULL)
323e0a4a 9983 error (_("cannot subscript or call a record"));
4c4b4cd2 9984 if (arity != nargs)
323e0a4a 9985 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 9986 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 9987 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
9988 return
9989 unwrap_value (ada_value_subscript
9990 (argvec[0], nargs, argvec + 1));
9991 }
9992 case TYPE_CODE_ARRAY:
9993 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9994 {
9995 type = ada_array_element_type (type, nargs);
9996 if (type == NULL)
323e0a4a 9997 error (_("element type of array unknown"));
4c4b4cd2 9998 else
0a07e705 9999 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10000 }
10001 return
10002 unwrap_value (ada_value_subscript
10003 (ada_coerce_to_simple_array (argvec[0]),
10004 nargs, argvec + 1));
10005 case TYPE_CODE_PTR: /* Pointer to array */
10006 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10007 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10008 {
10009 type = ada_array_element_type (type, nargs);
10010 if (type == NULL)
323e0a4a 10011 error (_("element type of array unknown"));
4c4b4cd2 10012 else
0a07e705 10013 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10014 }
10015 return
10016 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
10017 nargs, argvec + 1));
10018
10019 default:
e1d5a0d2
PH
10020 error (_("Attempt to index or call something other than an "
10021 "array or function"));
4c4b4cd2
PH
10022 }
10023
10024 case TERNOP_SLICE:
10025 {
10026 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10027 struct value *low_bound_val =
10028 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
10029 struct value *high_bound_val =
10030 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10031 LONGEST low_bound;
10032 LONGEST high_bound;
5b4ee69b 10033
994b9211
AC
10034 low_bound_val = coerce_ref (low_bound_val);
10035 high_bound_val = coerce_ref (high_bound_val);
714e53ab
PH
10036 low_bound = pos_atr (low_bound_val);
10037 high_bound = pos_atr (high_bound_val);
963a6417 10038
4c4b4cd2
PH
10039 if (noside == EVAL_SKIP)
10040 goto nosideret;
10041
4c4b4cd2
PH
10042 /* If this is a reference to an aligner type, then remove all
10043 the aligners. */
df407dfe
AC
10044 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10045 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10046 TYPE_TARGET_TYPE (value_type (array)) =
10047 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 10048
ad82864c 10049 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 10050 error (_("cannot slice a packed array"));
4c4b4cd2
PH
10051
10052 /* If this is a reference to an array or an array lvalue,
10053 convert to a pointer. */
df407dfe
AC
10054 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10055 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
10056 && VALUE_LVAL (array) == lval_memory))
10057 array = value_addr (array);
10058
1265e4aa 10059 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 10060 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 10061 (value_type (array))))
0b5d8877 10062 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
10063
10064 array = ada_coerce_to_simple_array_ptr (array);
10065
714e53ab
PH
10066 /* If we have more than one level of pointer indirection,
10067 dereference the value until we get only one level. */
df407dfe
AC
10068 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10069 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
10070 == TYPE_CODE_PTR))
10071 array = value_ind (array);
10072
10073 /* Make sure we really do have an array type before going further,
10074 to avoid a SEGV when trying to get the index type or the target
10075 type later down the road if the debug info generated by
10076 the compiler is incorrect or incomplete. */
df407dfe 10077 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 10078 error (_("cannot take slice of non-array"));
714e53ab 10079
828292f2
JB
10080 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10081 == TYPE_CODE_PTR)
4c4b4cd2 10082 {
828292f2
JB
10083 struct type *type0 = ada_check_typedef (value_type (array));
10084
0b5d8877 10085 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 10086 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
10087 else
10088 {
10089 struct type *arr_type0 =
828292f2 10090 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 10091
f5938064
JG
10092 return ada_value_slice_from_ptr (array, arr_type0,
10093 longest_to_int (low_bound),
10094 longest_to_int (high_bound));
4c4b4cd2
PH
10095 }
10096 }
10097 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10098 return array;
10099 else if (high_bound < low_bound)
df407dfe 10100 return empty_array (value_type (array), low_bound);
4c4b4cd2 10101 else
529cad9c
PH
10102 return ada_value_slice (array, longest_to_int (low_bound),
10103 longest_to_int (high_bound));
4c4b4cd2 10104 }
14f9c5c9 10105
4c4b4cd2
PH
10106 case UNOP_IN_RANGE:
10107 (*pos) += 2;
10108 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 10109 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 10110
14f9c5c9 10111 if (noside == EVAL_SKIP)
4c4b4cd2 10112 goto nosideret;
14f9c5c9 10113
4c4b4cd2
PH
10114 switch (TYPE_CODE (type))
10115 {
10116 default:
e1d5a0d2
PH
10117 lim_warning (_("Membership test incompletely implemented; "
10118 "always returns true"));
fbb06eb1
UW
10119 type = language_bool_type (exp->language_defn, exp->gdbarch);
10120 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
10121
10122 case TYPE_CODE_RANGE:
030b4912
UW
10123 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10124 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
10125 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10126 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
10127 type = language_bool_type (exp->language_defn, exp->gdbarch);
10128 return
10129 value_from_longest (type,
4c4b4cd2
PH
10130 (value_less (arg1, arg3)
10131 || value_equal (arg1, arg3))
10132 && (value_less (arg2, arg1)
10133 || value_equal (arg2, arg1)));
10134 }
10135
10136 case BINOP_IN_BOUNDS:
14f9c5c9 10137 (*pos) += 2;
4c4b4cd2
PH
10138 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10139 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10140
4c4b4cd2
PH
10141 if (noside == EVAL_SKIP)
10142 goto nosideret;
14f9c5c9 10143
4c4b4cd2 10144 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
10145 {
10146 type = language_bool_type (exp->language_defn, exp->gdbarch);
10147 return value_zero (type, not_lval);
10148 }
14f9c5c9 10149
4c4b4cd2 10150 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 10151
1eea4ebd
UW
10152 type = ada_index_type (value_type (arg2), tem, "range");
10153 if (!type)
10154 type = value_type (arg1);
14f9c5c9 10155
1eea4ebd
UW
10156 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10157 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 10158
f44316fa
UW
10159 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10160 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10161 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10162 return
fbb06eb1 10163 value_from_longest (type,
4c4b4cd2
PH
10164 (value_less (arg1, arg3)
10165 || value_equal (arg1, arg3))
10166 && (value_less (arg2, arg1)
10167 || value_equal (arg2, arg1)));
10168
10169 case TERNOP_IN_RANGE:
10170 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10171 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10172 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10173
10174 if (noside == EVAL_SKIP)
10175 goto nosideret;
10176
f44316fa
UW
10177 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10178 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10179 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10180 return
fbb06eb1 10181 value_from_longest (type,
4c4b4cd2
PH
10182 (value_less (arg1, arg3)
10183 || value_equal (arg1, arg3))
10184 && (value_less (arg2, arg1)
10185 || value_equal (arg2, arg1)));
10186
10187 case OP_ATR_FIRST:
10188 case OP_ATR_LAST:
10189 case OP_ATR_LENGTH:
10190 {
76a01679 10191 struct type *type_arg;
5b4ee69b 10192
76a01679
JB
10193 if (exp->elts[*pos].opcode == OP_TYPE)
10194 {
10195 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10196 arg1 = NULL;
5bc23cb3 10197 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
10198 }
10199 else
10200 {
10201 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10202 type_arg = NULL;
10203 }
10204
10205 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 10206 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
10207 tem = longest_to_int (exp->elts[*pos + 2].longconst);
10208 *pos += 4;
10209
10210 if (noside == EVAL_SKIP)
10211 goto nosideret;
10212
10213 if (type_arg == NULL)
10214 {
10215 arg1 = ada_coerce_ref (arg1);
10216
ad82864c 10217 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
10218 arg1 = ada_coerce_to_simple_array (arg1);
10219
1eea4ebd
UW
10220 type = ada_index_type (value_type (arg1), tem,
10221 ada_attribute_name (op));
10222 if (type == NULL)
10223 type = builtin_type (exp->gdbarch)->builtin_int;
76a01679
JB
10224
10225 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 10226 return allocate_value (type);
76a01679
JB
10227
10228 switch (op)
10229 {
10230 default: /* Should never happen. */
323e0a4a 10231 error (_("unexpected attribute encountered"));
76a01679 10232 case OP_ATR_FIRST:
1eea4ebd
UW
10233 return value_from_longest
10234 (type, ada_array_bound (arg1, tem, 0));
76a01679 10235 case OP_ATR_LAST:
1eea4ebd
UW
10236 return value_from_longest
10237 (type, ada_array_bound (arg1, tem, 1));
76a01679 10238 case OP_ATR_LENGTH:
1eea4ebd
UW
10239 return value_from_longest
10240 (type, ada_array_length (arg1, tem));
76a01679
JB
10241 }
10242 }
10243 else if (discrete_type_p (type_arg))
10244 {
10245 struct type *range_type;
0d5cff50 10246 const char *name = ada_type_name (type_arg);
5b4ee69b 10247
76a01679
JB
10248 range_type = NULL;
10249 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 10250 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
10251 if (range_type == NULL)
10252 range_type = type_arg;
10253 switch (op)
10254 {
10255 default:
323e0a4a 10256 error (_("unexpected attribute encountered"));
76a01679 10257 case OP_ATR_FIRST:
690cc4eb 10258 return value_from_longest
43bbcdc2 10259 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 10260 case OP_ATR_LAST:
690cc4eb 10261 return value_from_longest
43bbcdc2 10262 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 10263 case OP_ATR_LENGTH:
323e0a4a 10264 error (_("the 'length attribute applies only to array types"));
76a01679
JB
10265 }
10266 }
10267 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 10268 error (_("unimplemented type attribute"));
76a01679
JB
10269 else
10270 {
10271 LONGEST low, high;
10272
ad82864c
JB
10273 if (ada_is_constrained_packed_array_type (type_arg))
10274 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 10275
1eea4ebd 10276 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
76a01679 10277 if (type == NULL)
1eea4ebd
UW
10278 type = builtin_type (exp->gdbarch)->builtin_int;
10279
76a01679
JB
10280 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10281 return allocate_value (type);
10282
10283 switch (op)
10284 {
10285 default:
323e0a4a 10286 error (_("unexpected attribute encountered"));
76a01679 10287 case OP_ATR_FIRST:
1eea4ebd 10288 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
10289 return value_from_longest (type, low);
10290 case OP_ATR_LAST:
1eea4ebd 10291 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10292 return value_from_longest (type, high);
10293 case OP_ATR_LENGTH:
1eea4ebd
UW
10294 low = ada_array_bound_from_type (type_arg, tem, 0);
10295 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10296 return value_from_longest (type, high - low + 1);
10297 }
10298 }
14f9c5c9
AS
10299 }
10300
4c4b4cd2
PH
10301 case OP_ATR_TAG:
10302 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10303 if (noside == EVAL_SKIP)
76a01679 10304 goto nosideret;
4c4b4cd2
PH
10305
10306 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10307 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
10308
10309 return ada_value_tag (arg1);
10310
10311 case OP_ATR_MIN:
10312 case OP_ATR_MAX:
10313 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10314 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10315 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10316 if (noside == EVAL_SKIP)
76a01679 10317 goto nosideret;
d2e4a39e 10318 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10319 return value_zero (value_type (arg1), not_lval);
14f9c5c9 10320 else
f44316fa
UW
10321 {
10322 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10323 return value_binop (arg1, arg2,
10324 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
10325 }
14f9c5c9 10326
4c4b4cd2
PH
10327 case OP_ATR_MODULUS:
10328 {
31dedfee 10329 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 10330
5b4ee69b 10331 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
10332 if (noside == EVAL_SKIP)
10333 goto nosideret;
4c4b4cd2 10334
76a01679 10335 if (!ada_is_modular_type (type_arg))
323e0a4a 10336 error (_("'modulus must be applied to modular type"));
4c4b4cd2 10337
76a01679
JB
10338 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
10339 ada_modulus (type_arg));
4c4b4cd2
PH
10340 }
10341
10342
10343 case OP_ATR_POS:
10344 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10345 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10346 if (noside == EVAL_SKIP)
76a01679 10347 goto nosideret;
3cb382c9
UW
10348 type = builtin_type (exp->gdbarch)->builtin_int;
10349 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10350 return value_zero (type, not_lval);
14f9c5c9 10351 else
3cb382c9 10352 return value_pos_atr (type, arg1);
14f9c5c9 10353
4c4b4cd2
PH
10354 case OP_ATR_SIZE:
10355 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
10356 type = value_type (arg1);
10357
10358 /* If the argument is a reference, then dereference its type, since
10359 the user is really asking for the size of the actual object,
10360 not the size of the pointer. */
10361 if (TYPE_CODE (type) == TYPE_CODE_REF)
10362 type = TYPE_TARGET_TYPE (type);
10363
4c4b4cd2 10364 if (noside == EVAL_SKIP)
76a01679 10365 goto nosideret;
4c4b4cd2 10366 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 10367 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 10368 else
22601c15 10369 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 10370 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
10371
10372 case OP_ATR_VAL:
10373 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 10374 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 10375 type = exp->elts[pc + 2].type;
14f9c5c9 10376 if (noside == EVAL_SKIP)
76a01679 10377 goto nosideret;
4c4b4cd2 10378 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10379 return value_zero (type, not_lval);
4c4b4cd2 10380 else
76a01679 10381 return value_val_atr (type, arg1);
4c4b4cd2
PH
10382
10383 case BINOP_EXP:
10384 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10385 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10386 if (noside == EVAL_SKIP)
10387 goto nosideret;
10388 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10389 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 10390 else
f44316fa
UW
10391 {
10392 /* For integer exponentiation operations,
10393 only promote the first argument. */
10394 if (is_integral_type (value_type (arg2)))
10395 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10396 else
10397 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10398
10399 return value_binop (arg1, arg2, op);
10400 }
4c4b4cd2
PH
10401
10402 case UNOP_PLUS:
10403 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10404 if (noside == EVAL_SKIP)
10405 goto nosideret;
10406 else
10407 return arg1;
10408
10409 case UNOP_ABS:
10410 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10411 if (noside == EVAL_SKIP)
10412 goto nosideret;
f44316fa 10413 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 10414 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 10415 return value_neg (arg1);
14f9c5c9 10416 else
4c4b4cd2 10417 return arg1;
14f9c5c9
AS
10418
10419 case UNOP_IND:
6b0d7253 10420 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10421 if (noside == EVAL_SKIP)
4c4b4cd2 10422 goto nosideret;
df407dfe 10423 type = ada_check_typedef (value_type (arg1));
14f9c5c9 10424 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
10425 {
10426 if (ada_is_array_descriptor_type (type))
10427 /* GDB allows dereferencing GNAT array descriptors. */
10428 {
10429 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 10430
4c4b4cd2 10431 if (arrType == NULL)
323e0a4a 10432 error (_("Attempt to dereference null array pointer."));
00a4c844 10433 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
10434 }
10435 else if (TYPE_CODE (type) == TYPE_CODE_PTR
10436 || TYPE_CODE (type) == TYPE_CODE_REF
10437 /* In C you can dereference an array to get the 1st elt. */
10438 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab
PH
10439 {
10440 type = to_static_fixed_type
10441 (ada_aligned_type
10442 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10443 check_size (type);
10444 return value_zero (type, lval_memory);
10445 }
4c4b4cd2 10446 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
10447 {
10448 /* GDB allows dereferencing an int. */
10449 if (expect_type == NULL)
10450 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10451 lval_memory);
10452 else
10453 {
10454 expect_type =
10455 to_static_fixed_type (ada_aligned_type (expect_type));
10456 return value_zero (expect_type, lval_memory);
10457 }
10458 }
4c4b4cd2 10459 else
323e0a4a 10460 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 10461 }
0963b4bd 10462 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 10463 type = ada_check_typedef (value_type (arg1));
d2e4a39e 10464
96967637
JB
10465 if (TYPE_CODE (type) == TYPE_CODE_INT)
10466 /* GDB allows dereferencing an int. If we were given
10467 the expect_type, then use that as the target type.
10468 Otherwise, assume that the target type is an int. */
10469 {
10470 if (expect_type != NULL)
10471 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10472 arg1));
10473 else
10474 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10475 (CORE_ADDR) value_as_address (arg1));
10476 }
6b0d7253 10477
4c4b4cd2
PH
10478 if (ada_is_array_descriptor_type (type))
10479 /* GDB allows dereferencing GNAT array descriptors. */
10480 return ada_coerce_to_simple_array (arg1);
14f9c5c9 10481 else
4c4b4cd2 10482 return ada_value_ind (arg1);
14f9c5c9
AS
10483
10484 case STRUCTOP_STRUCT:
10485 tem = longest_to_int (exp->elts[pc + 1].longconst);
10486 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
10487 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10488 if (noside == EVAL_SKIP)
4c4b4cd2 10489 goto nosideret;
14f9c5c9 10490 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10491 {
df407dfe 10492 struct type *type1 = value_type (arg1);
5b4ee69b 10493
76a01679
JB
10494 if (ada_is_tagged_type (type1, 1))
10495 {
10496 type = ada_lookup_struct_elt_type (type1,
10497 &exp->elts[pc + 2].string,
10498 1, 1, NULL);
10499 if (type == NULL)
10500 /* In this case, we assume that the field COULD exist
10501 in some extension of the type. Return an object of
10502 "type" void, which will match any formal
0963b4bd 10503 (see ada_type_match). */
30b15541
UW
10504 return value_zero (builtin_type (exp->gdbarch)->builtin_void,
10505 lval_memory);
76a01679
JB
10506 }
10507 else
10508 type =
10509 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
10510 0, NULL);
10511
10512 return value_zero (ada_aligned_type (type), lval_memory);
10513 }
14f9c5c9 10514 else
284614f0
JB
10515 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
10516 arg1 = unwrap_value (arg1);
10517 return ada_to_fixed_value (arg1);
10518
14f9c5c9 10519 case OP_TYPE:
4c4b4cd2
PH
10520 /* The value is not supposed to be used. This is here to make it
10521 easier to accommodate expressions that contain types. */
14f9c5c9
AS
10522 (*pos) += 2;
10523 if (noside == EVAL_SKIP)
4c4b4cd2 10524 goto nosideret;
14f9c5c9 10525 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 10526 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 10527 else
323e0a4a 10528 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
10529
10530 case OP_AGGREGATE:
10531 case OP_CHOICES:
10532 case OP_OTHERS:
10533 case OP_DISCRETE_RANGE:
10534 case OP_POSITIONAL:
10535 case OP_NAME:
10536 if (noside == EVAL_NORMAL)
10537 switch (op)
10538 {
10539 case OP_NAME:
10540 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 10541 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
10542 case OP_AGGREGATE:
10543 error (_("Aggregates only allowed on the right of an assignment"));
10544 default:
0963b4bd
MS
10545 internal_error (__FILE__, __LINE__,
10546 _("aggregate apparently mangled"));
52ce6436
PH
10547 }
10548
10549 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10550 *pos += oplen - 1;
10551 for (tem = 0; tem < nargs; tem += 1)
10552 ada_evaluate_subexp (NULL, exp, pos, noside);
10553 goto nosideret;
14f9c5c9
AS
10554 }
10555
10556nosideret:
22601c15 10557 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
14f9c5c9 10558}
14f9c5c9 10559\f
d2e4a39e 10560
4c4b4cd2 10561 /* Fixed point */
14f9c5c9
AS
10562
10563/* If TYPE encodes an Ada fixed-point type, return the suffix of the
10564 type name that encodes the 'small and 'delta information.
4c4b4cd2 10565 Otherwise, return NULL. */
14f9c5c9 10566
d2e4a39e 10567static const char *
ebf56fd3 10568fixed_type_info (struct type *type)
14f9c5c9 10569{
d2e4a39e 10570 const char *name = ada_type_name (type);
14f9c5c9
AS
10571 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
10572
d2e4a39e
AS
10573 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
10574 {
14f9c5c9 10575 const char *tail = strstr (name, "___XF_");
5b4ee69b 10576
14f9c5c9 10577 if (tail == NULL)
4c4b4cd2 10578 return NULL;
d2e4a39e 10579 else
4c4b4cd2 10580 return tail + 5;
14f9c5c9
AS
10581 }
10582 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
10583 return fixed_type_info (TYPE_TARGET_TYPE (type));
10584 else
10585 return NULL;
10586}
10587
4c4b4cd2 10588/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
10589
10590int
ebf56fd3 10591ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
10592{
10593 return fixed_type_info (type) != NULL;
10594}
10595
4c4b4cd2
PH
10596/* Return non-zero iff TYPE represents a System.Address type. */
10597
10598int
10599ada_is_system_address_type (struct type *type)
10600{
10601 return (TYPE_NAME (type)
10602 && strcmp (TYPE_NAME (type), "system__address") == 0);
10603}
10604
14f9c5c9
AS
10605/* Assuming that TYPE is the representation of an Ada fixed-point
10606 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 10607 delta cannot be determined. */
14f9c5c9
AS
10608
10609DOUBLEST
ebf56fd3 10610ada_delta (struct type *type)
14f9c5c9
AS
10611{
10612 const char *encoding = fixed_type_info (type);
facc390f 10613 DOUBLEST num, den;
14f9c5c9 10614
facc390f
JB
10615 /* Strictly speaking, num and den are encoded as integer. However,
10616 they may not fit into a long, and they will have to be converted
10617 to DOUBLEST anyway. So scan them as DOUBLEST. */
10618 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10619 &num, &den) < 2)
14f9c5c9 10620 return -1.0;
d2e4a39e 10621 else
facc390f 10622 return num / den;
14f9c5c9
AS
10623}
10624
10625/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 10626 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
10627
10628static DOUBLEST
ebf56fd3 10629scaling_factor (struct type *type)
14f9c5c9
AS
10630{
10631 const char *encoding = fixed_type_info (type);
facc390f 10632 DOUBLEST num0, den0, num1, den1;
14f9c5c9 10633 int n;
d2e4a39e 10634
facc390f
JB
10635 /* Strictly speaking, num's and den's are encoded as integer. However,
10636 they may not fit into a long, and they will have to be converted
10637 to DOUBLEST anyway. So scan them as DOUBLEST. */
10638 n = sscanf (encoding,
10639 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
10640 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10641 &num0, &den0, &num1, &den1);
14f9c5c9
AS
10642
10643 if (n < 2)
10644 return 1.0;
10645 else if (n == 4)
facc390f 10646 return num1 / den1;
d2e4a39e 10647 else
facc390f 10648 return num0 / den0;
14f9c5c9
AS
10649}
10650
10651
10652/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 10653 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
10654
10655DOUBLEST
ebf56fd3 10656ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 10657{
d2e4a39e 10658 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
10659}
10660
4c4b4cd2
PH
10661/* The representation of a fixed-point value of type TYPE
10662 corresponding to the value X. */
14f9c5c9
AS
10663
10664LONGEST
ebf56fd3 10665ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
10666{
10667 return (LONGEST) (x / scaling_factor (type) + 0.5);
10668}
10669
14f9c5c9 10670\f
d2e4a39e 10671
4c4b4cd2 10672 /* Range types */
14f9c5c9
AS
10673
10674/* Scan STR beginning at position K for a discriminant name, and
10675 return the value of that discriminant field of DVAL in *PX. If
10676 PNEW_K is not null, put the position of the character beyond the
10677 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 10678 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
10679
10680static int
07d8f827 10681scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
76a01679 10682 int *pnew_k)
14f9c5c9
AS
10683{
10684 static char *bound_buffer = NULL;
10685 static size_t bound_buffer_len = 0;
10686 char *bound;
10687 char *pend;
d2e4a39e 10688 struct value *bound_val;
14f9c5c9
AS
10689
10690 if (dval == NULL || str == NULL || str[k] == '\0')
10691 return 0;
10692
d2e4a39e 10693 pend = strstr (str + k, "__");
14f9c5c9
AS
10694 if (pend == NULL)
10695 {
d2e4a39e 10696 bound = str + k;
14f9c5c9
AS
10697 k += strlen (bound);
10698 }
d2e4a39e 10699 else
14f9c5c9 10700 {
d2e4a39e 10701 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
14f9c5c9 10702 bound = bound_buffer;
d2e4a39e
AS
10703 strncpy (bound_buffer, str + k, pend - (str + k));
10704 bound[pend - (str + k)] = '\0';
10705 k = pend - str;
14f9c5c9 10706 }
d2e4a39e 10707
df407dfe 10708 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
10709 if (bound_val == NULL)
10710 return 0;
10711
10712 *px = value_as_long (bound_val);
10713 if (pnew_k != NULL)
10714 *pnew_k = k;
10715 return 1;
10716}
10717
10718/* Value of variable named NAME in the current environment. If
10719 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
10720 otherwise causes an error with message ERR_MSG. */
10721
d2e4a39e
AS
10722static struct value *
10723get_var_value (char *name, char *err_msg)
14f9c5c9 10724{
4c4b4cd2 10725 struct ada_symbol_info *syms;
14f9c5c9
AS
10726 int nsyms;
10727
4c4b4cd2 10728 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
4eeaa230 10729 &syms);
14f9c5c9
AS
10730
10731 if (nsyms != 1)
10732 {
10733 if (err_msg == NULL)
4c4b4cd2 10734 return 0;
14f9c5c9 10735 else
8a3fe4f8 10736 error (("%s"), err_msg);
14f9c5c9
AS
10737 }
10738
4c4b4cd2 10739 return value_of_variable (syms[0].sym, syms[0].block);
14f9c5c9 10740}
d2e4a39e 10741
14f9c5c9 10742/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
10743 no such variable found, returns 0, and sets *FLAG to 0. If
10744 successful, sets *FLAG to 1. */
10745
14f9c5c9 10746LONGEST
4c4b4cd2 10747get_int_var_value (char *name, int *flag)
14f9c5c9 10748{
4c4b4cd2 10749 struct value *var_val = get_var_value (name, 0);
d2e4a39e 10750
14f9c5c9
AS
10751 if (var_val == 0)
10752 {
10753 if (flag != NULL)
4c4b4cd2 10754 *flag = 0;
14f9c5c9
AS
10755 return 0;
10756 }
10757 else
10758 {
10759 if (flag != NULL)
4c4b4cd2 10760 *flag = 1;
14f9c5c9
AS
10761 return value_as_long (var_val);
10762 }
10763}
d2e4a39e 10764
14f9c5c9
AS
10765
10766/* Return a range type whose base type is that of the range type named
10767 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 10768 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
10769 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
10770 corresponding range type from debug information; fall back to using it
10771 if symbol lookup fails. If a new type must be created, allocate it
10772 like ORIG_TYPE was. The bounds information, in general, is encoded
10773 in NAME, the base type given in the named range type. */
14f9c5c9 10774
d2e4a39e 10775static struct type *
28c85d6c 10776to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 10777{
0d5cff50 10778 const char *name;
14f9c5c9 10779 struct type *base_type;
d2e4a39e 10780 char *subtype_info;
14f9c5c9 10781
28c85d6c
JB
10782 gdb_assert (raw_type != NULL);
10783 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 10784
1ce677a4 10785 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
10786 base_type = TYPE_TARGET_TYPE (raw_type);
10787 else
10788 base_type = raw_type;
10789
28c85d6c 10790 name = TYPE_NAME (raw_type);
14f9c5c9
AS
10791 subtype_info = strstr (name, "___XD");
10792 if (subtype_info == NULL)
690cc4eb 10793 {
43bbcdc2
PH
10794 LONGEST L = ada_discrete_type_low_bound (raw_type);
10795 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 10796
690cc4eb
PH
10797 if (L < INT_MIN || U > INT_MAX)
10798 return raw_type;
10799 else
28c85d6c 10800 return create_range_type (alloc_type_copy (raw_type), raw_type,
43bbcdc2
PH
10801 ada_discrete_type_low_bound (raw_type),
10802 ada_discrete_type_high_bound (raw_type));
690cc4eb 10803 }
14f9c5c9
AS
10804 else
10805 {
10806 static char *name_buf = NULL;
10807 static size_t name_len = 0;
10808 int prefix_len = subtype_info - name;
10809 LONGEST L, U;
10810 struct type *type;
10811 char *bounds_str;
10812 int n;
10813
10814 GROW_VECT (name_buf, name_len, prefix_len + 5);
10815 strncpy (name_buf, name, prefix_len);
10816 name_buf[prefix_len] = '\0';
10817
10818 subtype_info += 5;
10819 bounds_str = strchr (subtype_info, '_');
10820 n = 1;
10821
d2e4a39e 10822 if (*subtype_info == 'L')
4c4b4cd2
PH
10823 {
10824 if (!ada_scan_number (bounds_str, n, &L, &n)
10825 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
10826 return raw_type;
10827 if (bounds_str[n] == '_')
10828 n += 2;
0963b4bd 10829 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
10830 n += 1;
10831 subtype_info += 1;
10832 }
d2e4a39e 10833 else
4c4b4cd2
PH
10834 {
10835 int ok;
5b4ee69b 10836
4c4b4cd2
PH
10837 strcpy (name_buf + prefix_len, "___L");
10838 L = get_int_var_value (name_buf, &ok);
10839 if (!ok)
10840 {
323e0a4a 10841 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
10842 L = 1;
10843 }
10844 }
14f9c5c9 10845
d2e4a39e 10846 if (*subtype_info == 'U')
4c4b4cd2
PH
10847 {
10848 if (!ada_scan_number (bounds_str, n, &U, &n)
10849 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
10850 return raw_type;
10851 }
d2e4a39e 10852 else
4c4b4cd2
PH
10853 {
10854 int ok;
5b4ee69b 10855
4c4b4cd2
PH
10856 strcpy (name_buf + prefix_len, "___U");
10857 U = get_int_var_value (name_buf, &ok);
10858 if (!ok)
10859 {
323e0a4a 10860 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
10861 U = L;
10862 }
10863 }
14f9c5c9 10864
28c85d6c 10865 type = create_range_type (alloc_type_copy (raw_type), base_type, L, U);
d2e4a39e 10866 TYPE_NAME (type) = name;
14f9c5c9
AS
10867 return type;
10868 }
10869}
10870
4c4b4cd2
PH
10871/* True iff NAME is the name of a range type. */
10872
14f9c5c9 10873int
d2e4a39e 10874ada_is_range_type_name (const char *name)
14f9c5c9
AS
10875{
10876 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 10877}
14f9c5c9 10878\f
d2e4a39e 10879
4c4b4cd2
PH
10880 /* Modular types */
10881
10882/* True iff TYPE is an Ada modular type. */
14f9c5c9 10883
14f9c5c9 10884int
d2e4a39e 10885ada_is_modular_type (struct type *type)
14f9c5c9 10886{
18af8284 10887 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
10888
10889 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 10890 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 10891 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
10892}
10893
4c4b4cd2
PH
10894/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
10895
61ee279c 10896ULONGEST
0056e4d5 10897ada_modulus (struct type *type)
14f9c5c9 10898{
43bbcdc2 10899 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 10900}
d2e4a39e 10901\f
f7f9143b
JB
10902
10903/* Ada exception catchpoint support:
10904 ---------------------------------
10905
10906 We support 3 kinds of exception catchpoints:
10907 . catchpoints on Ada exceptions
10908 . catchpoints on unhandled Ada exceptions
10909 . catchpoints on failed assertions
10910
10911 Exceptions raised during failed assertions, or unhandled exceptions
10912 could perfectly be caught with the general catchpoint on Ada exceptions.
10913 However, we can easily differentiate these two special cases, and having
10914 the option to distinguish these two cases from the rest can be useful
10915 to zero-in on certain situations.
10916
10917 Exception catchpoints are a specialized form of breakpoint,
10918 since they rely on inserting breakpoints inside known routines
10919 of the GNAT runtime. The implementation therefore uses a standard
10920 breakpoint structure of the BP_BREAKPOINT type, but with its own set
10921 of breakpoint_ops.
10922
0259addd
JB
10923 Support in the runtime for exception catchpoints have been changed
10924 a few times already, and these changes affect the implementation
10925 of these catchpoints. In order to be able to support several
10926 variants of the runtime, we use a sniffer that will determine
28010a5d 10927 the runtime variant used by the program being debugged. */
f7f9143b
JB
10928
10929/* The different types of catchpoints that we introduced for catching
10930 Ada exceptions. */
10931
10932enum exception_catchpoint_kind
10933{
10934 ex_catch_exception,
10935 ex_catch_exception_unhandled,
10936 ex_catch_assert
10937};
10938
3d0b0fa3
JB
10939/* Ada's standard exceptions. */
10940
10941static char *standard_exc[] = {
10942 "constraint_error",
10943 "program_error",
10944 "storage_error",
10945 "tasking_error"
10946};
10947
0259addd
JB
10948typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
10949
10950/* A structure that describes how to support exception catchpoints
10951 for a given executable. */
10952
10953struct exception_support_info
10954{
10955 /* The name of the symbol to break on in order to insert
10956 a catchpoint on exceptions. */
10957 const char *catch_exception_sym;
10958
10959 /* The name of the symbol to break on in order to insert
10960 a catchpoint on unhandled exceptions. */
10961 const char *catch_exception_unhandled_sym;
10962
10963 /* The name of the symbol to break on in order to insert
10964 a catchpoint on failed assertions. */
10965 const char *catch_assert_sym;
10966
10967 /* Assuming that the inferior just triggered an unhandled exception
10968 catchpoint, this function is responsible for returning the address
10969 in inferior memory where the name of that exception is stored.
10970 Return zero if the address could not be computed. */
10971 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
10972};
10973
10974static CORE_ADDR ada_unhandled_exception_name_addr (void);
10975static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
10976
10977/* The following exception support info structure describes how to
10978 implement exception catchpoints with the latest version of the
10979 Ada runtime (as of 2007-03-06). */
10980
10981static const struct exception_support_info default_exception_support_info =
10982{
10983 "__gnat_debug_raise_exception", /* catch_exception_sym */
10984 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
10985 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
10986 ada_unhandled_exception_name_addr
10987};
10988
10989/* The following exception support info structure describes how to
10990 implement exception catchpoints with a slightly older version
10991 of the Ada runtime. */
10992
10993static const struct exception_support_info exception_support_info_fallback =
10994{
10995 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
10996 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
10997 "system__assertions__raise_assert_failure", /* catch_assert_sym */
10998 ada_unhandled_exception_name_addr_from_raise
10999};
11000
f17011e0
JB
11001/* Return nonzero if we can detect the exception support routines
11002 described in EINFO.
11003
11004 This function errors out if an abnormal situation is detected
11005 (for instance, if we find the exception support routines, but
11006 that support is found to be incomplete). */
11007
11008static int
11009ada_has_this_exception_support (const struct exception_support_info *einfo)
11010{
11011 struct symbol *sym;
11012
11013 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11014 that should be compiled with debugging information. As a result, we
11015 expect to find that symbol in the symtabs. */
11016
11017 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11018 if (sym == NULL)
a6af7abe
JB
11019 {
11020 /* Perhaps we did not find our symbol because the Ada runtime was
11021 compiled without debugging info, or simply stripped of it.
11022 It happens on some GNU/Linux distributions for instance, where
11023 users have to install a separate debug package in order to get
11024 the runtime's debugging info. In that situation, let the user
11025 know why we cannot insert an Ada exception catchpoint.
11026
11027 Note: Just for the purpose of inserting our Ada exception
11028 catchpoint, we could rely purely on the associated minimal symbol.
11029 But we would be operating in degraded mode anyway, since we are
11030 still lacking the debugging info needed later on to extract
11031 the name of the exception being raised (this name is printed in
11032 the catchpoint message, and is also used when trying to catch
11033 a specific exception). We do not handle this case for now. */
11034 if (lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL))
11035 error (_("Your Ada runtime appears to be missing some debugging "
11036 "information.\nCannot insert Ada exception catchpoint "
11037 "in this configuration."));
11038
11039 return 0;
11040 }
f17011e0
JB
11041
11042 /* Make sure that the symbol we found corresponds to a function. */
11043
11044 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11045 error (_("Symbol \"%s\" is not a function (class = %d)"),
11046 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11047
11048 return 1;
11049}
11050
0259addd
JB
11051/* Inspect the Ada runtime and determine which exception info structure
11052 should be used to provide support for exception catchpoints.
11053
3eecfa55
JB
11054 This function will always set the per-inferior exception_info,
11055 or raise an error. */
0259addd
JB
11056
11057static void
11058ada_exception_support_info_sniffer (void)
11059{
3eecfa55 11060 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
11061
11062 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 11063 if (data->exception_info != NULL)
0259addd
JB
11064 return;
11065
11066 /* Check the latest (default) exception support info. */
f17011e0 11067 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 11068 {
3eecfa55 11069 data->exception_info = &default_exception_support_info;
0259addd
JB
11070 return;
11071 }
11072
11073 /* Try our fallback exception suport info. */
f17011e0 11074 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 11075 {
3eecfa55 11076 data->exception_info = &exception_support_info_fallback;
0259addd
JB
11077 return;
11078 }
11079
11080 /* Sometimes, it is normal for us to not be able to find the routine
11081 we are looking for. This happens when the program is linked with
11082 the shared version of the GNAT runtime, and the program has not been
11083 started yet. Inform the user of these two possible causes if
11084 applicable. */
11085
ccefe4c4 11086 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
11087 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11088
11089 /* If the symbol does not exist, then check that the program is
11090 already started, to make sure that shared libraries have been
11091 loaded. If it is not started, this may mean that the symbol is
11092 in a shared library. */
11093
11094 if (ptid_get_pid (inferior_ptid) == 0)
11095 error (_("Unable to insert catchpoint. Try to start the program first."));
11096
11097 /* At this point, we know that we are debugging an Ada program and
11098 that the inferior has been started, but we still are not able to
0963b4bd 11099 find the run-time symbols. That can mean that we are in
0259addd
JB
11100 configurable run time mode, or that a-except as been optimized
11101 out by the linker... In any case, at this point it is not worth
11102 supporting this feature. */
11103
7dda8cff 11104 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
11105}
11106
f7f9143b
JB
11107/* True iff FRAME is very likely to be that of a function that is
11108 part of the runtime system. This is all very heuristic, but is
11109 intended to be used as advice as to what frames are uninteresting
11110 to most users. */
11111
11112static int
11113is_known_support_routine (struct frame_info *frame)
11114{
4ed6b5be 11115 struct symtab_and_line sal;
0d5cff50 11116 const char *func_name;
692465f1 11117 enum language func_lang;
f7f9143b 11118 int i;
f35a17b5 11119 const char *fullname;
f7f9143b 11120
4ed6b5be
JB
11121 /* If this code does not have any debugging information (no symtab),
11122 This cannot be any user code. */
f7f9143b 11123
4ed6b5be 11124 find_frame_sal (frame, &sal);
f7f9143b
JB
11125 if (sal.symtab == NULL)
11126 return 1;
11127
4ed6b5be
JB
11128 /* If there is a symtab, but the associated source file cannot be
11129 located, then assume this is not user code: Selecting a frame
11130 for which we cannot display the code would not be very helpful
11131 for the user. This should also take care of case such as VxWorks
11132 where the kernel has some debugging info provided for a few units. */
f7f9143b 11133
f35a17b5
JK
11134 fullname = symtab_to_fullname (sal.symtab);
11135 if (access (fullname, R_OK) != 0)
f7f9143b
JB
11136 return 1;
11137
4ed6b5be
JB
11138 /* Check the unit filename againt the Ada runtime file naming.
11139 We also check the name of the objfile against the name of some
11140 known system libraries that sometimes come with debugging info
11141 too. */
11142
f7f9143b
JB
11143 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11144 {
11145 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 11146 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 11147 return 1;
4ed6b5be
JB
11148 if (sal.symtab->objfile != NULL
11149 && re_exec (sal.symtab->objfile->name))
11150 return 1;
f7f9143b
JB
11151 }
11152
4ed6b5be 11153 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 11154
e9e07ba6 11155 find_frame_funname (frame, &func_name, &func_lang, NULL);
f7f9143b
JB
11156 if (func_name == NULL)
11157 return 1;
11158
11159 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11160 {
11161 re_comp (known_auxiliary_function_name_patterns[i]);
11162 if (re_exec (func_name))
11163 return 1;
11164 }
11165
11166 return 0;
11167}
11168
11169/* Find the first frame that contains debugging information and that is not
11170 part of the Ada run-time, starting from FI and moving upward. */
11171
0ef643c8 11172void
f7f9143b
JB
11173ada_find_printable_frame (struct frame_info *fi)
11174{
11175 for (; fi != NULL; fi = get_prev_frame (fi))
11176 {
11177 if (!is_known_support_routine (fi))
11178 {
11179 select_frame (fi);
11180 break;
11181 }
11182 }
11183
11184}
11185
11186/* Assuming that the inferior just triggered an unhandled exception
11187 catchpoint, return the address in inferior memory where the name
11188 of the exception is stored.
11189
11190 Return zero if the address could not be computed. */
11191
11192static CORE_ADDR
11193ada_unhandled_exception_name_addr (void)
0259addd
JB
11194{
11195 return parse_and_eval_address ("e.full_name");
11196}
11197
11198/* Same as ada_unhandled_exception_name_addr, except that this function
11199 should be used when the inferior uses an older version of the runtime,
11200 where the exception name needs to be extracted from a specific frame
11201 several frames up in the callstack. */
11202
11203static CORE_ADDR
11204ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
11205{
11206 int frame_level;
11207 struct frame_info *fi;
3eecfa55 11208 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
f7f9143b
JB
11209
11210 /* To determine the name of this exception, we need to select
11211 the frame corresponding to RAISE_SYM_NAME. This frame is
11212 at least 3 levels up, so we simply skip the first 3 frames
11213 without checking the name of their associated function. */
11214 fi = get_current_frame ();
11215 for (frame_level = 0; frame_level < 3; frame_level += 1)
11216 if (fi != NULL)
11217 fi = get_prev_frame (fi);
11218
11219 while (fi != NULL)
11220 {
0d5cff50 11221 const char *func_name;
692465f1
JB
11222 enum language func_lang;
11223
e9e07ba6 11224 find_frame_funname (fi, &func_name, &func_lang, NULL);
f7f9143b 11225 if (func_name != NULL
3eecfa55 11226 && strcmp (func_name, data->exception_info->catch_exception_sym) == 0)
f7f9143b
JB
11227 break; /* We found the frame we were looking for... */
11228 fi = get_prev_frame (fi);
11229 }
11230
11231 if (fi == NULL)
11232 return 0;
11233
11234 select_frame (fi);
11235 return parse_and_eval_address ("id.full_name");
11236}
11237
11238/* Assuming the inferior just triggered an Ada exception catchpoint
11239 (of any type), return the address in inferior memory where the name
11240 of the exception is stored, if applicable.
11241
11242 Return zero if the address could not be computed, or if not relevant. */
11243
11244static CORE_ADDR
11245ada_exception_name_addr_1 (enum exception_catchpoint_kind ex,
11246 struct breakpoint *b)
11247{
3eecfa55
JB
11248 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11249
f7f9143b
JB
11250 switch (ex)
11251 {
11252 case ex_catch_exception:
11253 return (parse_and_eval_address ("e.full_name"));
11254 break;
11255
11256 case ex_catch_exception_unhandled:
3eecfa55 11257 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
11258 break;
11259
11260 case ex_catch_assert:
11261 return 0; /* Exception name is not relevant in this case. */
11262 break;
11263
11264 default:
11265 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11266 break;
11267 }
11268
11269 return 0; /* Should never be reached. */
11270}
11271
11272/* Same as ada_exception_name_addr_1, except that it intercepts and contains
11273 any error that ada_exception_name_addr_1 might cause to be thrown.
11274 When an error is intercepted, a warning with the error message is printed,
11275 and zero is returned. */
11276
11277static CORE_ADDR
11278ada_exception_name_addr (enum exception_catchpoint_kind ex,
11279 struct breakpoint *b)
11280{
bfd189b1 11281 volatile struct gdb_exception e;
f7f9143b
JB
11282 CORE_ADDR result = 0;
11283
11284 TRY_CATCH (e, RETURN_MASK_ERROR)
11285 {
11286 result = ada_exception_name_addr_1 (ex, b);
11287 }
11288
11289 if (e.reason < 0)
11290 {
11291 warning (_("failed to get exception name: %s"), e.message);
11292 return 0;
11293 }
11294
11295 return result;
11296}
11297
28010a5d
PA
11298static struct symtab_and_line ada_exception_sal (enum exception_catchpoint_kind,
11299 char *, char **,
c0a91b2b 11300 const struct breakpoint_ops **);
28010a5d
PA
11301static char *ada_exception_catchpoint_cond_string (const char *excep_string);
11302
11303/* Ada catchpoints.
11304
11305 In the case of catchpoints on Ada exceptions, the catchpoint will
11306 stop the target on every exception the program throws. When a user
11307 specifies the name of a specific exception, we translate this
11308 request into a condition expression (in text form), and then parse
11309 it into an expression stored in each of the catchpoint's locations.
11310 We then use this condition to check whether the exception that was
11311 raised is the one the user is interested in. If not, then the
11312 target is resumed again. We store the name of the requested
11313 exception, in order to be able to re-set the condition expression
11314 when symbols change. */
11315
11316/* An instance of this type is used to represent an Ada catchpoint
11317 breakpoint location. It includes a "struct bp_location" as a kind
11318 of base class; users downcast to "struct bp_location *" when
11319 needed. */
11320
11321struct ada_catchpoint_location
11322{
11323 /* The base class. */
11324 struct bp_location base;
11325
11326 /* The condition that checks whether the exception that was raised
11327 is the specific exception the user specified on catchpoint
11328 creation. */
11329 struct expression *excep_cond_expr;
11330};
11331
11332/* Implement the DTOR method in the bp_location_ops structure for all
11333 Ada exception catchpoint kinds. */
11334
11335static void
11336ada_catchpoint_location_dtor (struct bp_location *bl)
11337{
11338 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
11339
11340 xfree (al->excep_cond_expr);
11341}
11342
11343/* The vtable to be used in Ada catchpoint locations. */
11344
11345static const struct bp_location_ops ada_catchpoint_location_ops =
11346{
11347 ada_catchpoint_location_dtor
11348};
11349
11350/* An instance of this type is used to represent an Ada catchpoint.
11351 It includes a "struct breakpoint" as a kind of base class; users
11352 downcast to "struct breakpoint *" when needed. */
11353
11354struct ada_catchpoint
11355{
11356 /* The base class. */
11357 struct breakpoint base;
11358
11359 /* The name of the specific exception the user specified. */
11360 char *excep_string;
11361};
11362
11363/* Parse the exception condition string in the context of each of the
11364 catchpoint's locations, and store them for later evaluation. */
11365
11366static void
11367create_excep_cond_exprs (struct ada_catchpoint *c)
11368{
11369 struct cleanup *old_chain;
11370 struct bp_location *bl;
11371 char *cond_string;
11372
11373 /* Nothing to do if there's no specific exception to catch. */
11374 if (c->excep_string == NULL)
11375 return;
11376
11377 /* Same if there are no locations... */
11378 if (c->base.loc == NULL)
11379 return;
11380
11381 /* Compute the condition expression in text form, from the specific
11382 expection we want to catch. */
11383 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
11384 old_chain = make_cleanup (xfree, cond_string);
11385
11386 /* Iterate over all the catchpoint's locations, and parse an
11387 expression for each. */
11388 for (bl = c->base.loc; bl != NULL; bl = bl->next)
11389 {
11390 struct ada_catchpoint_location *ada_loc
11391 = (struct ada_catchpoint_location *) bl;
11392 struct expression *exp = NULL;
11393
11394 if (!bl->shlib_disabled)
11395 {
11396 volatile struct gdb_exception e;
bbc13ae3 11397 const char *s;
28010a5d
PA
11398
11399 s = cond_string;
11400 TRY_CATCH (e, RETURN_MASK_ERROR)
11401 {
1bb9788d
TT
11402 exp = parse_exp_1 (&s, bl->address,
11403 block_for_pc (bl->address), 0);
28010a5d
PA
11404 }
11405 if (e.reason < 0)
11406 warning (_("failed to reevaluate internal exception condition "
11407 "for catchpoint %d: %s"),
11408 c->base.number, e.message);
11409 }
11410
11411 ada_loc->excep_cond_expr = exp;
11412 }
11413
11414 do_cleanups (old_chain);
11415}
11416
11417/* Implement the DTOR method in the breakpoint_ops structure for all
11418 exception catchpoint kinds. */
11419
11420static void
11421dtor_exception (enum exception_catchpoint_kind ex, struct breakpoint *b)
11422{
11423 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11424
11425 xfree (c->excep_string);
348d480f 11426
2060206e 11427 bkpt_breakpoint_ops.dtor (b);
28010a5d
PA
11428}
11429
11430/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11431 structure for all exception catchpoint kinds. */
11432
11433static struct bp_location *
11434allocate_location_exception (enum exception_catchpoint_kind ex,
11435 struct breakpoint *self)
11436{
11437 struct ada_catchpoint_location *loc;
11438
11439 loc = XNEW (struct ada_catchpoint_location);
11440 init_bp_location (&loc->base, &ada_catchpoint_location_ops, self);
11441 loc->excep_cond_expr = NULL;
11442 return &loc->base;
11443}
11444
11445/* Implement the RE_SET method in the breakpoint_ops structure for all
11446 exception catchpoint kinds. */
11447
11448static void
11449re_set_exception (enum exception_catchpoint_kind ex, struct breakpoint *b)
11450{
11451 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11452
11453 /* Call the base class's method. This updates the catchpoint's
11454 locations. */
2060206e 11455 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
11456
11457 /* Reparse the exception conditional expressions. One for each
11458 location. */
11459 create_excep_cond_exprs (c);
11460}
11461
11462/* Returns true if we should stop for this breakpoint hit. If the
11463 user specified a specific exception, we only want to cause a stop
11464 if the program thrown that exception. */
11465
11466static int
11467should_stop_exception (const struct bp_location *bl)
11468{
11469 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11470 const struct ada_catchpoint_location *ada_loc
11471 = (const struct ada_catchpoint_location *) bl;
11472 volatile struct gdb_exception ex;
11473 int stop;
11474
11475 /* With no specific exception, should always stop. */
11476 if (c->excep_string == NULL)
11477 return 1;
11478
11479 if (ada_loc->excep_cond_expr == NULL)
11480 {
11481 /* We will have a NULL expression if back when we were creating
11482 the expressions, this location's had failed to parse. */
11483 return 1;
11484 }
11485
11486 stop = 1;
11487 TRY_CATCH (ex, RETURN_MASK_ALL)
11488 {
11489 struct value *mark;
11490
11491 mark = value_mark ();
11492 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr));
11493 value_free_to_mark (mark);
11494 }
11495 if (ex.reason < 0)
11496 exception_fprintf (gdb_stderr, ex,
11497 _("Error in testing exception condition:\n"));
11498 return stop;
11499}
11500
11501/* Implement the CHECK_STATUS method in the breakpoint_ops structure
11502 for all exception catchpoint kinds. */
11503
11504static void
11505check_status_exception (enum exception_catchpoint_kind ex, bpstat bs)
11506{
11507 bs->stop = should_stop_exception (bs->bp_location_at);
11508}
11509
f7f9143b
JB
11510/* Implement the PRINT_IT method in the breakpoint_ops structure
11511 for all exception catchpoint kinds. */
11512
11513static enum print_stop_action
348d480f 11514print_it_exception (enum exception_catchpoint_kind ex, bpstat bs)
f7f9143b 11515{
79a45e25 11516 struct ui_out *uiout = current_uiout;
348d480f
PA
11517 struct breakpoint *b = bs->breakpoint_at;
11518
956a9fb9 11519 annotate_catchpoint (b->number);
f7f9143b 11520
956a9fb9 11521 if (ui_out_is_mi_like_p (uiout))
f7f9143b 11522 {
956a9fb9
JB
11523 ui_out_field_string (uiout, "reason",
11524 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11525 ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition));
f7f9143b
JB
11526 }
11527
00eb2c4a
JB
11528 ui_out_text (uiout,
11529 b->disposition == disp_del ? "\nTemporary catchpoint "
11530 : "\nCatchpoint ");
956a9fb9
JB
11531 ui_out_field_int (uiout, "bkptno", b->number);
11532 ui_out_text (uiout, ", ");
f7f9143b 11533
f7f9143b
JB
11534 switch (ex)
11535 {
11536 case ex_catch_exception:
f7f9143b 11537 case ex_catch_exception_unhandled:
956a9fb9
JB
11538 {
11539 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
11540 char exception_name[256];
11541
11542 if (addr != 0)
11543 {
c714b426
PA
11544 read_memory (addr, (gdb_byte *) exception_name,
11545 sizeof (exception_name) - 1);
956a9fb9
JB
11546 exception_name [sizeof (exception_name) - 1] = '\0';
11547 }
11548 else
11549 {
11550 /* For some reason, we were unable to read the exception
11551 name. This could happen if the Runtime was compiled
11552 without debugging info, for instance. In that case,
11553 just replace the exception name by the generic string
11554 "exception" - it will read as "an exception" in the
11555 notification we are about to print. */
967cff16 11556 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
11557 }
11558 /* In the case of unhandled exception breakpoints, we print
11559 the exception name as "unhandled EXCEPTION_NAME", to make
11560 it clearer to the user which kind of catchpoint just got
11561 hit. We used ui_out_text to make sure that this extra
11562 info does not pollute the exception name in the MI case. */
11563 if (ex == ex_catch_exception_unhandled)
11564 ui_out_text (uiout, "unhandled ");
11565 ui_out_field_string (uiout, "exception-name", exception_name);
11566 }
11567 break;
f7f9143b 11568 case ex_catch_assert:
956a9fb9
JB
11569 /* In this case, the name of the exception is not really
11570 important. Just print "failed assertion" to make it clearer
11571 that his program just hit an assertion-failure catchpoint.
11572 We used ui_out_text because this info does not belong in
11573 the MI output. */
11574 ui_out_text (uiout, "failed assertion");
11575 break;
f7f9143b 11576 }
956a9fb9
JB
11577 ui_out_text (uiout, " at ");
11578 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
11579
11580 return PRINT_SRC_AND_LOC;
11581}
11582
11583/* Implement the PRINT_ONE method in the breakpoint_ops structure
11584 for all exception catchpoint kinds. */
11585
11586static void
11587print_one_exception (enum exception_catchpoint_kind ex,
a6d9a66e 11588 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11589{
79a45e25 11590 struct ui_out *uiout = current_uiout;
28010a5d 11591 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
11592 struct value_print_options opts;
11593
11594 get_user_print_options (&opts);
11595 if (opts.addressprint)
f7f9143b
JB
11596 {
11597 annotate_field (4);
5af949e3 11598 ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
11599 }
11600
11601 annotate_field (5);
a6d9a66e 11602 *last_loc = b->loc;
f7f9143b
JB
11603 switch (ex)
11604 {
11605 case ex_catch_exception:
28010a5d 11606 if (c->excep_string != NULL)
f7f9143b 11607 {
28010a5d
PA
11608 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11609
f7f9143b
JB
11610 ui_out_field_string (uiout, "what", msg);
11611 xfree (msg);
11612 }
11613 else
11614 ui_out_field_string (uiout, "what", "all Ada exceptions");
11615
11616 break;
11617
11618 case ex_catch_exception_unhandled:
11619 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
11620 break;
11621
11622 case ex_catch_assert:
11623 ui_out_field_string (uiout, "what", "failed Ada assertions");
11624 break;
11625
11626 default:
11627 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11628 break;
11629 }
11630}
11631
11632/* Implement the PRINT_MENTION method in the breakpoint_ops structure
11633 for all exception catchpoint kinds. */
11634
11635static void
11636print_mention_exception (enum exception_catchpoint_kind ex,
11637 struct breakpoint *b)
11638{
28010a5d 11639 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 11640 struct ui_out *uiout = current_uiout;
28010a5d 11641
00eb2c4a
JB
11642 ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ")
11643 : _("Catchpoint "));
11644 ui_out_field_int (uiout, "bkptno", b->number);
11645 ui_out_text (uiout, ": ");
11646
f7f9143b
JB
11647 switch (ex)
11648 {
11649 case ex_catch_exception:
28010a5d 11650 if (c->excep_string != NULL)
00eb2c4a
JB
11651 {
11652 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11653 struct cleanup *old_chain = make_cleanup (xfree, info);
11654
11655 ui_out_text (uiout, info);
11656 do_cleanups (old_chain);
11657 }
f7f9143b 11658 else
00eb2c4a 11659 ui_out_text (uiout, _("all Ada exceptions"));
f7f9143b
JB
11660 break;
11661
11662 case ex_catch_exception_unhandled:
00eb2c4a 11663 ui_out_text (uiout, _("unhandled Ada exceptions"));
f7f9143b
JB
11664 break;
11665
11666 case ex_catch_assert:
00eb2c4a 11667 ui_out_text (uiout, _("failed Ada assertions"));
f7f9143b
JB
11668 break;
11669
11670 default:
11671 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11672 break;
11673 }
11674}
11675
6149aea9
PA
11676/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
11677 for all exception catchpoint kinds. */
11678
11679static void
11680print_recreate_exception (enum exception_catchpoint_kind ex,
11681 struct breakpoint *b, struct ui_file *fp)
11682{
28010a5d
PA
11683 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11684
6149aea9
PA
11685 switch (ex)
11686 {
11687 case ex_catch_exception:
11688 fprintf_filtered (fp, "catch exception");
28010a5d
PA
11689 if (c->excep_string != NULL)
11690 fprintf_filtered (fp, " %s", c->excep_string);
6149aea9
PA
11691 break;
11692
11693 case ex_catch_exception_unhandled:
78076abc 11694 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
11695 break;
11696
11697 case ex_catch_assert:
11698 fprintf_filtered (fp, "catch assert");
11699 break;
11700
11701 default:
11702 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11703 }
d9b3f62e 11704 print_recreate_thread (b, fp);
6149aea9
PA
11705}
11706
f7f9143b
JB
11707/* Virtual table for "catch exception" breakpoints. */
11708
28010a5d
PA
11709static void
11710dtor_catch_exception (struct breakpoint *b)
11711{
11712 dtor_exception (ex_catch_exception, b);
11713}
11714
11715static struct bp_location *
11716allocate_location_catch_exception (struct breakpoint *self)
11717{
11718 return allocate_location_exception (ex_catch_exception, self);
11719}
11720
11721static void
11722re_set_catch_exception (struct breakpoint *b)
11723{
11724 re_set_exception (ex_catch_exception, b);
11725}
11726
11727static void
11728check_status_catch_exception (bpstat bs)
11729{
11730 check_status_exception (ex_catch_exception, bs);
11731}
11732
f7f9143b 11733static enum print_stop_action
348d480f 11734print_it_catch_exception (bpstat bs)
f7f9143b 11735{
348d480f 11736 return print_it_exception (ex_catch_exception, bs);
f7f9143b
JB
11737}
11738
11739static void
a6d9a66e 11740print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11741{
a6d9a66e 11742 print_one_exception (ex_catch_exception, b, last_loc);
f7f9143b
JB
11743}
11744
11745static void
11746print_mention_catch_exception (struct breakpoint *b)
11747{
11748 print_mention_exception (ex_catch_exception, b);
11749}
11750
6149aea9
PA
11751static void
11752print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
11753{
11754 print_recreate_exception (ex_catch_exception, b, fp);
11755}
11756
2060206e 11757static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
11758
11759/* Virtual table for "catch exception unhandled" breakpoints. */
11760
28010a5d
PA
11761static void
11762dtor_catch_exception_unhandled (struct breakpoint *b)
11763{
11764 dtor_exception (ex_catch_exception_unhandled, b);
11765}
11766
11767static struct bp_location *
11768allocate_location_catch_exception_unhandled (struct breakpoint *self)
11769{
11770 return allocate_location_exception (ex_catch_exception_unhandled, self);
11771}
11772
11773static void
11774re_set_catch_exception_unhandled (struct breakpoint *b)
11775{
11776 re_set_exception (ex_catch_exception_unhandled, b);
11777}
11778
11779static void
11780check_status_catch_exception_unhandled (bpstat bs)
11781{
11782 check_status_exception (ex_catch_exception_unhandled, bs);
11783}
11784
f7f9143b 11785static enum print_stop_action
348d480f 11786print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 11787{
348d480f 11788 return print_it_exception (ex_catch_exception_unhandled, bs);
f7f9143b
JB
11789}
11790
11791static void
a6d9a66e
UW
11792print_one_catch_exception_unhandled (struct breakpoint *b,
11793 struct bp_location **last_loc)
f7f9143b 11794{
a6d9a66e 11795 print_one_exception (ex_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
11796}
11797
11798static void
11799print_mention_catch_exception_unhandled (struct breakpoint *b)
11800{
11801 print_mention_exception (ex_catch_exception_unhandled, b);
11802}
11803
6149aea9
PA
11804static void
11805print_recreate_catch_exception_unhandled (struct breakpoint *b,
11806 struct ui_file *fp)
11807{
11808 print_recreate_exception (ex_catch_exception_unhandled, b, fp);
11809}
11810
2060206e 11811static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
11812
11813/* Virtual table for "catch assert" breakpoints. */
11814
28010a5d
PA
11815static void
11816dtor_catch_assert (struct breakpoint *b)
11817{
11818 dtor_exception (ex_catch_assert, b);
11819}
11820
11821static struct bp_location *
11822allocate_location_catch_assert (struct breakpoint *self)
11823{
11824 return allocate_location_exception (ex_catch_assert, self);
11825}
11826
11827static void
11828re_set_catch_assert (struct breakpoint *b)
11829{
843e694d 11830 re_set_exception (ex_catch_assert, b);
28010a5d
PA
11831}
11832
11833static void
11834check_status_catch_assert (bpstat bs)
11835{
11836 check_status_exception (ex_catch_assert, bs);
11837}
11838
f7f9143b 11839static enum print_stop_action
348d480f 11840print_it_catch_assert (bpstat bs)
f7f9143b 11841{
348d480f 11842 return print_it_exception (ex_catch_assert, bs);
f7f9143b
JB
11843}
11844
11845static void
a6d9a66e 11846print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11847{
a6d9a66e 11848 print_one_exception (ex_catch_assert, b, last_loc);
f7f9143b
JB
11849}
11850
11851static void
11852print_mention_catch_assert (struct breakpoint *b)
11853{
11854 print_mention_exception (ex_catch_assert, b);
11855}
11856
6149aea9
PA
11857static void
11858print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
11859{
11860 print_recreate_exception (ex_catch_assert, b, fp);
11861}
11862
2060206e 11863static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 11864
f7f9143b
JB
11865/* Return a newly allocated copy of the first space-separated token
11866 in ARGSP, and then adjust ARGSP to point immediately after that
11867 token.
11868
11869 Return NULL if ARGPS does not contain any more tokens. */
11870
11871static char *
11872ada_get_next_arg (char **argsp)
11873{
11874 char *args = *argsp;
11875 char *end;
11876 char *result;
11877
0fcd72ba 11878 args = skip_spaces (args);
f7f9143b
JB
11879 if (args[0] == '\0')
11880 return NULL; /* No more arguments. */
11881
11882 /* Find the end of the current argument. */
11883
0fcd72ba 11884 end = skip_to_space (args);
f7f9143b
JB
11885
11886 /* Adjust ARGSP to point to the start of the next argument. */
11887
11888 *argsp = end;
11889
11890 /* Make a copy of the current argument and return it. */
11891
11892 result = xmalloc (end - args + 1);
11893 strncpy (result, args, end - args);
11894 result[end - args] = '\0';
11895
11896 return result;
11897}
11898
11899/* Split the arguments specified in a "catch exception" command.
11900 Set EX to the appropriate catchpoint type.
28010a5d 11901 Set EXCEP_STRING to the name of the specific exception if
5845583d
JB
11902 specified by the user.
11903 If a condition is found at the end of the arguments, the condition
11904 expression is stored in COND_STRING (memory must be deallocated
11905 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
11906
11907static void
11908catch_ada_exception_command_split (char *args,
11909 enum exception_catchpoint_kind *ex,
5845583d
JB
11910 char **excep_string,
11911 char **cond_string)
f7f9143b
JB
11912{
11913 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
11914 char *exception_name;
5845583d 11915 char *cond = NULL;
f7f9143b
JB
11916
11917 exception_name = ada_get_next_arg (&args);
5845583d
JB
11918 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
11919 {
11920 /* This is not an exception name; this is the start of a condition
11921 expression for a catchpoint on all exceptions. So, "un-get"
11922 this token, and set exception_name to NULL. */
11923 xfree (exception_name);
11924 exception_name = NULL;
11925 args -= 2;
11926 }
f7f9143b
JB
11927 make_cleanup (xfree, exception_name);
11928
5845583d 11929 /* Check to see if we have a condition. */
f7f9143b 11930
0fcd72ba 11931 args = skip_spaces (args);
5845583d
JB
11932 if (strncmp (args, "if", 2) == 0
11933 && (isspace (args[2]) || args[2] == '\0'))
11934 {
11935 args += 2;
11936 args = skip_spaces (args);
11937
11938 if (args[0] == '\0')
11939 error (_("Condition missing after `if' keyword"));
11940 cond = xstrdup (args);
11941 make_cleanup (xfree, cond);
11942
11943 args += strlen (args);
11944 }
11945
11946 /* Check that we do not have any more arguments. Anything else
11947 is unexpected. */
f7f9143b
JB
11948
11949 if (args[0] != '\0')
11950 error (_("Junk at end of expression"));
11951
11952 discard_cleanups (old_chain);
11953
11954 if (exception_name == NULL)
11955 {
11956 /* Catch all exceptions. */
11957 *ex = ex_catch_exception;
28010a5d 11958 *excep_string = NULL;
f7f9143b
JB
11959 }
11960 else if (strcmp (exception_name, "unhandled") == 0)
11961 {
11962 /* Catch unhandled exceptions. */
11963 *ex = ex_catch_exception_unhandled;
28010a5d 11964 *excep_string = NULL;
f7f9143b
JB
11965 }
11966 else
11967 {
11968 /* Catch a specific exception. */
11969 *ex = ex_catch_exception;
28010a5d 11970 *excep_string = exception_name;
f7f9143b 11971 }
5845583d 11972 *cond_string = cond;
f7f9143b
JB
11973}
11974
11975/* Return the name of the symbol on which we should break in order to
11976 implement a catchpoint of the EX kind. */
11977
11978static const char *
11979ada_exception_sym_name (enum exception_catchpoint_kind ex)
11980{
3eecfa55
JB
11981 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11982
11983 gdb_assert (data->exception_info != NULL);
0259addd 11984
f7f9143b
JB
11985 switch (ex)
11986 {
11987 case ex_catch_exception:
3eecfa55 11988 return (data->exception_info->catch_exception_sym);
f7f9143b
JB
11989 break;
11990 case ex_catch_exception_unhandled:
3eecfa55 11991 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b
JB
11992 break;
11993 case ex_catch_assert:
3eecfa55 11994 return (data->exception_info->catch_assert_sym);
f7f9143b
JB
11995 break;
11996 default:
11997 internal_error (__FILE__, __LINE__,
11998 _("unexpected catchpoint kind (%d)"), ex);
11999 }
12000}
12001
12002/* Return the breakpoint ops "virtual table" used for catchpoints
12003 of the EX kind. */
12004
c0a91b2b 12005static const struct breakpoint_ops *
4b9eee8c 12006ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex)
f7f9143b
JB
12007{
12008 switch (ex)
12009 {
12010 case ex_catch_exception:
12011 return (&catch_exception_breakpoint_ops);
12012 break;
12013 case ex_catch_exception_unhandled:
12014 return (&catch_exception_unhandled_breakpoint_ops);
12015 break;
12016 case ex_catch_assert:
12017 return (&catch_assert_breakpoint_ops);
12018 break;
12019 default:
12020 internal_error (__FILE__, __LINE__,
12021 _("unexpected catchpoint kind (%d)"), ex);
12022 }
12023}
12024
12025/* Return the condition that will be used to match the current exception
12026 being raised with the exception that the user wants to catch. This
12027 assumes that this condition is used when the inferior just triggered
12028 an exception catchpoint.
12029
12030 The string returned is a newly allocated string that needs to be
12031 deallocated later. */
12032
12033static char *
28010a5d 12034ada_exception_catchpoint_cond_string (const char *excep_string)
f7f9143b 12035{
3d0b0fa3
JB
12036 int i;
12037
0963b4bd 12038 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 12039 runtime units that have been compiled without debugging info; if
28010a5d 12040 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
12041 exception (e.g. "constraint_error") then, during the evaluation
12042 of the condition expression, the symbol lookup on this name would
0963b4bd 12043 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
12044 may then be set only on user-defined exceptions which have the
12045 same not-fully-qualified name (e.g. my_package.constraint_error).
12046
12047 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 12048 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
12049 exception constraint_error" is rewritten into "catch exception
12050 standard.constraint_error".
12051
12052 If an exception named contraint_error is defined in another package of
12053 the inferior program, then the only way to specify this exception as a
12054 breakpoint condition is to use its fully-qualified named:
12055 e.g. my_package.constraint_error. */
12056
12057 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12058 {
28010a5d 12059 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3
JB
12060 {
12061 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
28010a5d 12062 excep_string);
3d0b0fa3
JB
12063 }
12064 }
28010a5d 12065 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
f7f9143b
JB
12066}
12067
12068/* Return the symtab_and_line that should be used to insert an exception
12069 catchpoint of the TYPE kind.
12070
28010a5d
PA
12071 EXCEP_STRING should contain the name of a specific exception that
12072 the catchpoint should catch, or NULL otherwise.
f7f9143b 12073
28010a5d
PA
12074 ADDR_STRING returns the name of the function where the real
12075 breakpoint that implements the catchpoints is set, depending on the
12076 type of catchpoint we need to create. */
f7f9143b
JB
12077
12078static struct symtab_and_line
28010a5d 12079ada_exception_sal (enum exception_catchpoint_kind ex, char *excep_string,
c0a91b2b 12080 char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
12081{
12082 const char *sym_name;
12083 struct symbol *sym;
f7f9143b 12084
0259addd
JB
12085 /* First, find out which exception support info to use. */
12086 ada_exception_support_info_sniffer ();
12087
12088 /* Then lookup the function on which we will break in order to catch
f7f9143b 12089 the Ada exceptions requested by the user. */
f7f9143b
JB
12090 sym_name = ada_exception_sym_name (ex);
12091 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12092
f17011e0
JB
12093 /* We can assume that SYM is not NULL at this stage. If the symbol
12094 did not exist, ada_exception_support_info_sniffer would have
12095 raised an exception.
f7f9143b 12096
f17011e0
JB
12097 Also, ada_exception_support_info_sniffer should have already
12098 verified that SYM is a function symbol. */
12099 gdb_assert (sym != NULL);
12100 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
12101
12102 /* Set ADDR_STRING. */
f7f9143b
JB
12103 *addr_string = xstrdup (sym_name);
12104
f7f9143b 12105 /* Set OPS. */
4b9eee8c 12106 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 12107
f17011e0 12108 return find_function_start_sal (sym, 1);
f7f9143b
JB
12109}
12110
12111/* Parse the arguments (ARGS) of the "catch exception" command.
12112
f7f9143b
JB
12113 If the user asked the catchpoint to catch only a specific
12114 exception, then save the exception name in ADDR_STRING.
12115
5845583d
JB
12116 If the user provided a condition, then set COND_STRING to
12117 that condition expression (the memory must be deallocated
12118 after use). Otherwise, set COND_STRING to NULL.
12119
f7f9143b
JB
12120 See ada_exception_sal for a description of all the remaining
12121 function arguments of this function. */
12122
9ac4176b 12123static struct symtab_and_line
f7f9143b 12124ada_decode_exception_location (char *args, char **addr_string,
28010a5d 12125 char **excep_string,
5845583d 12126 char **cond_string,
c0a91b2b 12127 const struct breakpoint_ops **ops)
f7f9143b
JB
12128{
12129 enum exception_catchpoint_kind ex;
12130
5845583d 12131 catch_ada_exception_command_split (args, &ex, excep_string, cond_string);
28010a5d
PA
12132 return ada_exception_sal (ex, *excep_string, addr_string, ops);
12133}
12134
12135/* Create an Ada exception catchpoint. */
12136
12137static void
12138create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12139 struct symtab_and_line sal,
12140 char *addr_string,
12141 char *excep_string,
5845583d 12142 char *cond_string,
c0a91b2b 12143 const struct breakpoint_ops *ops,
28010a5d
PA
12144 int tempflag,
12145 int from_tty)
12146{
12147 struct ada_catchpoint *c;
12148
12149 c = XNEW (struct ada_catchpoint);
12150 init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string,
12151 ops, tempflag, from_tty);
12152 c->excep_string = excep_string;
12153 create_excep_cond_exprs (c);
5845583d
JB
12154 if (cond_string != NULL)
12155 set_breakpoint_condition (&c->base, cond_string, from_tty);
3ea46bff 12156 install_breakpoint (0, &c->base, 1);
f7f9143b
JB
12157}
12158
9ac4176b
PA
12159/* Implement the "catch exception" command. */
12160
12161static void
12162catch_ada_exception_command (char *arg, int from_tty,
12163 struct cmd_list_element *command)
12164{
12165 struct gdbarch *gdbarch = get_current_arch ();
12166 int tempflag;
12167 struct symtab_and_line sal;
12168 char *addr_string = NULL;
28010a5d 12169 char *excep_string = NULL;
5845583d 12170 char *cond_string = NULL;
c0a91b2b 12171 const struct breakpoint_ops *ops = NULL;
9ac4176b
PA
12172
12173 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12174
12175 if (!arg)
12176 arg = "";
5845583d
JB
12177 sal = ada_decode_exception_location (arg, &addr_string, &excep_string,
12178 &cond_string, &ops);
28010a5d 12179 create_ada_exception_catchpoint (gdbarch, sal, addr_string,
5845583d
JB
12180 excep_string, cond_string, ops,
12181 tempflag, from_tty);
9ac4176b
PA
12182}
12183
5845583d
JB
12184/* Assuming that ARGS contains the arguments of a "catch assert"
12185 command, parse those arguments and return a symtab_and_line object
12186 for a failed assertion catchpoint.
12187
12188 Set ADDR_STRING to the name of the function where the real
12189 breakpoint that implements the catchpoint is set.
12190
12191 If ARGS contains a condition, set COND_STRING to that condition
12192 (the memory needs to be deallocated after use). Otherwise, set
12193 COND_STRING to NULL. */
12194
9ac4176b 12195static struct symtab_and_line
f7f9143b 12196ada_decode_assert_location (char *args, char **addr_string,
5845583d 12197 char **cond_string,
c0a91b2b 12198 const struct breakpoint_ops **ops)
f7f9143b 12199{
5845583d 12200 args = skip_spaces (args);
f7f9143b 12201
5845583d
JB
12202 /* Check whether a condition was provided. */
12203 if (strncmp (args, "if", 2) == 0
12204 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 12205 {
5845583d 12206 args += 2;
0fcd72ba 12207 args = skip_spaces (args);
5845583d
JB
12208 if (args[0] == '\0')
12209 error (_("condition missing after `if' keyword"));
12210 *cond_string = xstrdup (args);
f7f9143b
JB
12211 }
12212
5845583d
JB
12213 /* Otherwise, there should be no other argument at the end of
12214 the command. */
12215 else if (args[0] != '\0')
12216 error (_("Junk at end of arguments."));
12217
28010a5d 12218 return ada_exception_sal (ex_catch_assert, NULL, addr_string, ops);
f7f9143b
JB
12219}
12220
9ac4176b
PA
12221/* Implement the "catch assert" command. */
12222
12223static void
12224catch_assert_command (char *arg, int from_tty,
12225 struct cmd_list_element *command)
12226{
12227 struct gdbarch *gdbarch = get_current_arch ();
12228 int tempflag;
12229 struct symtab_and_line sal;
12230 char *addr_string = NULL;
5845583d 12231 char *cond_string = NULL;
c0a91b2b 12232 const struct breakpoint_ops *ops = NULL;
9ac4176b
PA
12233
12234 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12235
12236 if (!arg)
12237 arg = "";
5845583d 12238 sal = ada_decode_assert_location (arg, &addr_string, &cond_string, &ops);
28010a5d 12239 create_ada_exception_catchpoint (gdbarch, sal, addr_string,
5845583d
JB
12240 NULL, cond_string, ops, tempflag,
12241 from_tty);
9ac4176b 12242}
4c4b4cd2
PH
12243 /* Operators */
12244/* Information about operators given special treatment in functions
12245 below. */
12246/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
12247
12248#define ADA_OPERATORS \
12249 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
12250 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
12251 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
12252 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
12253 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
12254 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
12255 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
12256 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
12257 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
12258 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
12259 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
12260 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
12261 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
12262 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
12263 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
12264 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
12265 OP_DEFN (OP_OTHERS, 1, 1, 0) \
12266 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
12267 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
12268
12269static void
554794dc
SDJ
12270ada_operator_length (const struct expression *exp, int pc, int *oplenp,
12271 int *argsp)
4c4b4cd2
PH
12272{
12273 switch (exp->elts[pc - 1].opcode)
12274 {
76a01679 12275 default:
4c4b4cd2
PH
12276 operator_length_standard (exp, pc, oplenp, argsp);
12277 break;
12278
12279#define OP_DEFN(op, len, args, binop) \
12280 case op: *oplenp = len; *argsp = args; break;
12281 ADA_OPERATORS;
12282#undef OP_DEFN
52ce6436
PH
12283
12284 case OP_AGGREGATE:
12285 *oplenp = 3;
12286 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
12287 break;
12288
12289 case OP_CHOICES:
12290 *oplenp = 3;
12291 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
12292 break;
4c4b4cd2
PH
12293 }
12294}
12295
c0201579
JK
12296/* Implementation of the exp_descriptor method operator_check. */
12297
12298static int
12299ada_operator_check (struct expression *exp, int pos,
12300 int (*objfile_func) (struct objfile *objfile, void *data),
12301 void *data)
12302{
12303 const union exp_element *const elts = exp->elts;
12304 struct type *type = NULL;
12305
12306 switch (elts[pos].opcode)
12307 {
12308 case UNOP_IN_RANGE:
12309 case UNOP_QUAL:
12310 type = elts[pos + 1].type;
12311 break;
12312
12313 default:
12314 return operator_check_standard (exp, pos, objfile_func, data);
12315 }
12316
12317 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
12318
12319 if (type && TYPE_OBJFILE (type)
12320 && (*objfile_func) (TYPE_OBJFILE (type), data))
12321 return 1;
12322
12323 return 0;
12324}
12325
4c4b4cd2
PH
12326static char *
12327ada_op_name (enum exp_opcode opcode)
12328{
12329 switch (opcode)
12330 {
76a01679 12331 default:
4c4b4cd2 12332 return op_name_standard (opcode);
52ce6436 12333
4c4b4cd2
PH
12334#define OP_DEFN(op, len, args, binop) case op: return #op;
12335 ADA_OPERATORS;
12336#undef OP_DEFN
52ce6436
PH
12337
12338 case OP_AGGREGATE:
12339 return "OP_AGGREGATE";
12340 case OP_CHOICES:
12341 return "OP_CHOICES";
12342 case OP_NAME:
12343 return "OP_NAME";
4c4b4cd2
PH
12344 }
12345}
12346
12347/* As for operator_length, but assumes PC is pointing at the first
12348 element of the operator, and gives meaningful results only for the
52ce6436 12349 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
12350
12351static void
76a01679
JB
12352ada_forward_operator_length (struct expression *exp, int pc,
12353 int *oplenp, int *argsp)
4c4b4cd2 12354{
76a01679 12355 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
12356 {
12357 default:
12358 *oplenp = *argsp = 0;
12359 break;
52ce6436 12360
4c4b4cd2
PH
12361#define OP_DEFN(op, len, args, binop) \
12362 case op: *oplenp = len; *argsp = args; break;
12363 ADA_OPERATORS;
12364#undef OP_DEFN
52ce6436
PH
12365
12366 case OP_AGGREGATE:
12367 *oplenp = 3;
12368 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
12369 break;
12370
12371 case OP_CHOICES:
12372 *oplenp = 3;
12373 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
12374 break;
12375
12376 case OP_STRING:
12377 case OP_NAME:
12378 {
12379 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 12380
52ce6436
PH
12381 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
12382 *argsp = 0;
12383 break;
12384 }
4c4b4cd2
PH
12385 }
12386}
12387
12388static int
12389ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
12390{
12391 enum exp_opcode op = exp->elts[elt].opcode;
12392 int oplen, nargs;
12393 int pc = elt;
12394 int i;
76a01679 12395
4c4b4cd2
PH
12396 ada_forward_operator_length (exp, elt, &oplen, &nargs);
12397
76a01679 12398 switch (op)
4c4b4cd2 12399 {
76a01679 12400 /* Ada attributes ('Foo). */
4c4b4cd2
PH
12401 case OP_ATR_FIRST:
12402 case OP_ATR_LAST:
12403 case OP_ATR_LENGTH:
12404 case OP_ATR_IMAGE:
12405 case OP_ATR_MAX:
12406 case OP_ATR_MIN:
12407 case OP_ATR_MODULUS:
12408 case OP_ATR_POS:
12409 case OP_ATR_SIZE:
12410 case OP_ATR_TAG:
12411 case OP_ATR_VAL:
12412 break;
12413
12414 case UNOP_IN_RANGE:
12415 case UNOP_QUAL:
323e0a4a
AC
12416 /* XXX: gdb_sprint_host_address, type_sprint */
12417 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
12418 gdb_print_host_address (exp->elts[pc + 1].type, stream);
12419 fprintf_filtered (stream, " (");
12420 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
12421 fprintf_filtered (stream, ")");
12422 break;
12423 case BINOP_IN_BOUNDS:
52ce6436
PH
12424 fprintf_filtered (stream, " (%d)",
12425 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
12426 break;
12427 case TERNOP_IN_RANGE:
12428 break;
12429
52ce6436
PH
12430 case OP_AGGREGATE:
12431 case OP_OTHERS:
12432 case OP_DISCRETE_RANGE:
12433 case OP_POSITIONAL:
12434 case OP_CHOICES:
12435 break;
12436
12437 case OP_NAME:
12438 case OP_STRING:
12439 {
12440 char *name = &exp->elts[elt + 2].string;
12441 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 12442
52ce6436
PH
12443 fprintf_filtered (stream, "Text: `%.*s'", len, name);
12444 break;
12445 }
12446
4c4b4cd2
PH
12447 default:
12448 return dump_subexp_body_standard (exp, stream, elt);
12449 }
12450
12451 elt += oplen;
12452 for (i = 0; i < nargs; i += 1)
12453 elt = dump_subexp (exp, stream, elt);
12454
12455 return elt;
12456}
12457
12458/* The Ada extension of print_subexp (q.v.). */
12459
76a01679
JB
12460static void
12461ada_print_subexp (struct expression *exp, int *pos,
12462 struct ui_file *stream, enum precedence prec)
4c4b4cd2 12463{
52ce6436 12464 int oplen, nargs, i;
4c4b4cd2
PH
12465 int pc = *pos;
12466 enum exp_opcode op = exp->elts[pc].opcode;
12467
12468 ada_forward_operator_length (exp, pc, &oplen, &nargs);
12469
52ce6436 12470 *pos += oplen;
4c4b4cd2
PH
12471 switch (op)
12472 {
12473 default:
52ce6436 12474 *pos -= oplen;
4c4b4cd2
PH
12475 print_subexp_standard (exp, pos, stream, prec);
12476 return;
12477
12478 case OP_VAR_VALUE:
4c4b4cd2
PH
12479 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
12480 return;
12481
12482 case BINOP_IN_BOUNDS:
323e0a4a 12483 /* XXX: sprint_subexp */
4c4b4cd2 12484 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12485 fputs_filtered (" in ", stream);
4c4b4cd2 12486 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12487 fputs_filtered ("'range", stream);
4c4b4cd2 12488 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
12489 fprintf_filtered (stream, "(%ld)",
12490 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
12491 return;
12492
12493 case TERNOP_IN_RANGE:
4c4b4cd2 12494 if (prec >= PREC_EQUAL)
76a01679 12495 fputs_filtered ("(", stream);
323e0a4a 12496 /* XXX: sprint_subexp */
4c4b4cd2 12497 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12498 fputs_filtered (" in ", stream);
4c4b4cd2
PH
12499 print_subexp (exp, pos, stream, PREC_EQUAL);
12500 fputs_filtered (" .. ", stream);
12501 print_subexp (exp, pos, stream, PREC_EQUAL);
12502 if (prec >= PREC_EQUAL)
76a01679
JB
12503 fputs_filtered (")", stream);
12504 return;
4c4b4cd2
PH
12505
12506 case OP_ATR_FIRST:
12507 case OP_ATR_LAST:
12508 case OP_ATR_LENGTH:
12509 case OP_ATR_IMAGE:
12510 case OP_ATR_MAX:
12511 case OP_ATR_MIN:
12512 case OP_ATR_MODULUS:
12513 case OP_ATR_POS:
12514 case OP_ATR_SIZE:
12515 case OP_ATR_TAG:
12516 case OP_ATR_VAL:
4c4b4cd2 12517 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
12518 {
12519 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
12520 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
12521 &type_print_raw_options);
76a01679
JB
12522 *pos += 3;
12523 }
4c4b4cd2 12524 else
76a01679 12525 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
12526 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
12527 if (nargs > 1)
76a01679
JB
12528 {
12529 int tem;
5b4ee69b 12530
76a01679
JB
12531 for (tem = 1; tem < nargs; tem += 1)
12532 {
12533 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
12534 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
12535 }
12536 fputs_filtered (")", stream);
12537 }
4c4b4cd2 12538 return;
14f9c5c9 12539
4c4b4cd2 12540 case UNOP_QUAL:
4c4b4cd2
PH
12541 type_print (exp->elts[pc + 1].type, "", stream, 0);
12542 fputs_filtered ("'(", stream);
12543 print_subexp (exp, pos, stream, PREC_PREFIX);
12544 fputs_filtered (")", stream);
12545 return;
14f9c5c9 12546
4c4b4cd2 12547 case UNOP_IN_RANGE:
323e0a4a 12548 /* XXX: sprint_subexp */
4c4b4cd2 12549 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12550 fputs_filtered (" in ", stream);
79d43c61
TT
12551 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
12552 &type_print_raw_options);
4c4b4cd2 12553 return;
52ce6436
PH
12554
12555 case OP_DISCRETE_RANGE:
12556 print_subexp (exp, pos, stream, PREC_SUFFIX);
12557 fputs_filtered ("..", stream);
12558 print_subexp (exp, pos, stream, PREC_SUFFIX);
12559 return;
12560
12561 case OP_OTHERS:
12562 fputs_filtered ("others => ", stream);
12563 print_subexp (exp, pos, stream, PREC_SUFFIX);
12564 return;
12565
12566 case OP_CHOICES:
12567 for (i = 0; i < nargs-1; i += 1)
12568 {
12569 if (i > 0)
12570 fputs_filtered ("|", stream);
12571 print_subexp (exp, pos, stream, PREC_SUFFIX);
12572 }
12573 fputs_filtered (" => ", stream);
12574 print_subexp (exp, pos, stream, PREC_SUFFIX);
12575 return;
12576
12577 case OP_POSITIONAL:
12578 print_subexp (exp, pos, stream, PREC_SUFFIX);
12579 return;
12580
12581 case OP_AGGREGATE:
12582 fputs_filtered ("(", stream);
12583 for (i = 0; i < nargs; i += 1)
12584 {
12585 if (i > 0)
12586 fputs_filtered (", ", stream);
12587 print_subexp (exp, pos, stream, PREC_SUFFIX);
12588 }
12589 fputs_filtered (")", stream);
12590 return;
4c4b4cd2
PH
12591 }
12592}
14f9c5c9
AS
12593
12594/* Table mapping opcodes into strings for printing operators
12595 and precedences of the operators. */
12596
d2e4a39e
AS
12597static const struct op_print ada_op_print_tab[] = {
12598 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
12599 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
12600 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
12601 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
12602 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
12603 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
12604 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
12605 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
12606 {"<=", BINOP_LEQ, PREC_ORDER, 0},
12607 {">=", BINOP_GEQ, PREC_ORDER, 0},
12608 {">", BINOP_GTR, PREC_ORDER, 0},
12609 {"<", BINOP_LESS, PREC_ORDER, 0},
12610 {">>", BINOP_RSH, PREC_SHIFT, 0},
12611 {"<<", BINOP_LSH, PREC_SHIFT, 0},
12612 {"+", BINOP_ADD, PREC_ADD, 0},
12613 {"-", BINOP_SUB, PREC_ADD, 0},
12614 {"&", BINOP_CONCAT, PREC_ADD, 0},
12615 {"*", BINOP_MUL, PREC_MUL, 0},
12616 {"/", BINOP_DIV, PREC_MUL, 0},
12617 {"rem", BINOP_REM, PREC_MUL, 0},
12618 {"mod", BINOP_MOD, PREC_MUL, 0},
12619 {"**", BINOP_EXP, PREC_REPEAT, 0},
12620 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
12621 {"-", UNOP_NEG, PREC_PREFIX, 0},
12622 {"+", UNOP_PLUS, PREC_PREFIX, 0},
12623 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
12624 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
12625 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
12626 {".all", UNOP_IND, PREC_SUFFIX, 1},
12627 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
12628 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
d2e4a39e 12629 {NULL, 0, 0, 0}
14f9c5c9
AS
12630};
12631\f
72d5681a
PH
12632enum ada_primitive_types {
12633 ada_primitive_type_int,
12634 ada_primitive_type_long,
12635 ada_primitive_type_short,
12636 ada_primitive_type_char,
12637 ada_primitive_type_float,
12638 ada_primitive_type_double,
12639 ada_primitive_type_void,
12640 ada_primitive_type_long_long,
12641 ada_primitive_type_long_double,
12642 ada_primitive_type_natural,
12643 ada_primitive_type_positive,
12644 ada_primitive_type_system_address,
12645 nr_ada_primitive_types
12646};
6c038f32
PH
12647
12648static void
d4a9a881 12649ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
12650 struct language_arch_info *lai)
12651{
d4a9a881 12652 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 12653
72d5681a 12654 lai->primitive_type_vector
d4a9a881 12655 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 12656 struct type *);
e9bb382b
UW
12657
12658 lai->primitive_type_vector [ada_primitive_type_int]
12659 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12660 0, "integer");
12661 lai->primitive_type_vector [ada_primitive_type_long]
12662 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
12663 0, "long_integer");
12664 lai->primitive_type_vector [ada_primitive_type_short]
12665 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
12666 0, "short_integer");
12667 lai->string_char_type
12668 = lai->primitive_type_vector [ada_primitive_type_char]
12669 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
12670 lai->primitive_type_vector [ada_primitive_type_float]
12671 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
12672 "float", NULL);
12673 lai->primitive_type_vector [ada_primitive_type_double]
12674 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
12675 "long_float", NULL);
12676 lai->primitive_type_vector [ada_primitive_type_long_long]
12677 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
12678 0, "long_long_integer");
12679 lai->primitive_type_vector [ada_primitive_type_long_double]
12680 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
12681 "long_long_float", NULL);
12682 lai->primitive_type_vector [ada_primitive_type_natural]
12683 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12684 0, "natural");
12685 lai->primitive_type_vector [ada_primitive_type_positive]
12686 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12687 0, "positive");
12688 lai->primitive_type_vector [ada_primitive_type_void]
12689 = builtin->builtin_void;
12690
12691 lai->primitive_type_vector [ada_primitive_type_system_address]
12692 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
72d5681a
PH
12693 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
12694 = "system__address";
fbb06eb1 12695
47e729a8 12696 lai->bool_type_symbol = NULL;
fbb06eb1 12697 lai->bool_type_default = builtin->builtin_bool;
6c038f32 12698}
6c038f32
PH
12699\f
12700 /* Language vector */
12701
12702/* Not really used, but needed in the ada_language_defn. */
12703
12704static void
6c7a06a3 12705emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 12706{
6c7a06a3 12707 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
12708}
12709
12710static int
12711parse (void)
12712{
12713 warnings_issued = 0;
12714 return ada_parse ();
12715}
12716
12717static const struct exp_descriptor ada_exp_descriptor = {
12718 ada_print_subexp,
12719 ada_operator_length,
c0201579 12720 ada_operator_check,
6c038f32
PH
12721 ada_op_name,
12722 ada_dump_subexp_body,
12723 ada_evaluate_subexp
12724};
12725
1a119f36 12726/* Implement the "la_get_symbol_name_cmp" language_defn method
74ccd7f5
JB
12727 for Ada. */
12728
1a119f36
JB
12729static symbol_name_cmp_ftype
12730ada_get_symbol_name_cmp (const char *lookup_name)
74ccd7f5
JB
12731{
12732 if (should_use_wild_match (lookup_name))
12733 return wild_match;
12734 else
12735 return compare_names;
12736}
12737
a5ee536b
JB
12738/* Implement the "la_read_var_value" language_defn method for Ada. */
12739
12740static struct value *
12741ada_read_var_value (struct symbol *var, struct frame_info *frame)
12742{
12743 struct block *frame_block = NULL;
12744 struct symbol *renaming_sym = NULL;
12745
12746 /* The only case where default_read_var_value is not sufficient
12747 is when VAR is a renaming... */
12748 if (frame)
12749 frame_block = get_frame_block (frame, NULL);
12750 if (frame_block)
12751 renaming_sym = ada_find_renaming_symbol (var, frame_block);
12752 if (renaming_sym != NULL)
12753 return ada_read_renaming_var_value (renaming_sym, frame_block);
12754
12755 /* This is a typical case where we expect the default_read_var_value
12756 function to work. */
12757 return default_read_var_value (var, frame);
12758}
12759
6c038f32
PH
12760const struct language_defn ada_language_defn = {
12761 "ada", /* Language name */
12762 language_ada,
6c038f32 12763 range_check_off,
6c038f32
PH
12764 case_sensitive_on, /* Yes, Ada is case-insensitive, but
12765 that's not quite what this means. */
6c038f32 12766 array_row_major,
9a044a89 12767 macro_expansion_no,
6c038f32
PH
12768 &ada_exp_descriptor,
12769 parse,
12770 ada_error,
12771 resolve,
12772 ada_printchar, /* Print a character constant */
12773 ada_printstr, /* Function to print string constant */
12774 emit_char, /* Function to print single char (not used) */
6c038f32 12775 ada_print_type, /* Print a type using appropriate syntax */
be942545 12776 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
12777 ada_val_print, /* Print a value using appropriate syntax */
12778 ada_value_print, /* Print a top-level value */
a5ee536b 12779 ada_read_var_value, /* la_read_var_value */
6c038f32 12780 NULL, /* Language specific skip_trampoline */
2b2d9e11 12781 NULL, /* name_of_this */
6c038f32
PH
12782 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
12783 basic_lookup_transparent_type, /* lookup_transparent_type */
12784 ada_la_decode, /* Language specific symbol demangler */
0963b4bd
MS
12785 NULL, /* Language specific
12786 class_name_from_physname */
6c038f32
PH
12787 ada_op_print_tab, /* expression operators for printing */
12788 0, /* c-style arrays */
12789 1, /* String lower bound */
6c038f32 12790 ada_get_gdb_completer_word_break_characters,
41d27058 12791 ada_make_symbol_completion_list,
72d5681a 12792 ada_language_arch_info,
e79af960 12793 ada_print_array_index,
41f1b697 12794 default_pass_by_reference,
ae6a3a4c 12795 c_get_string,
1a119f36 12796 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
f8eba3c6 12797 ada_iterate_over_symbols,
6c038f32
PH
12798 LANG_MAGIC
12799};
12800
2c0b251b
PA
12801/* Provide a prototype to silence -Wmissing-prototypes. */
12802extern initialize_file_ftype _initialize_ada_language;
12803
5bf03f13
JB
12804/* Command-list for the "set/show ada" prefix command. */
12805static struct cmd_list_element *set_ada_list;
12806static struct cmd_list_element *show_ada_list;
12807
12808/* Implement the "set ada" prefix command. */
12809
12810static void
12811set_ada_command (char *arg, int from_tty)
12812{
12813 printf_unfiltered (_(\
12814"\"set ada\" must be followed by the name of a setting.\n"));
12815 help_list (set_ada_list, "set ada ", -1, gdb_stdout);
12816}
12817
12818/* Implement the "show ada" prefix command. */
12819
12820static void
12821show_ada_command (char *args, int from_tty)
12822{
12823 cmd_show_list (show_ada_list, from_tty, "");
12824}
12825
2060206e
PA
12826static void
12827initialize_ada_catchpoint_ops (void)
12828{
12829 struct breakpoint_ops *ops;
12830
12831 initialize_breakpoint_ops ();
12832
12833 ops = &catch_exception_breakpoint_ops;
12834 *ops = bkpt_breakpoint_ops;
12835 ops->dtor = dtor_catch_exception;
12836 ops->allocate_location = allocate_location_catch_exception;
12837 ops->re_set = re_set_catch_exception;
12838 ops->check_status = check_status_catch_exception;
12839 ops->print_it = print_it_catch_exception;
12840 ops->print_one = print_one_catch_exception;
12841 ops->print_mention = print_mention_catch_exception;
12842 ops->print_recreate = print_recreate_catch_exception;
12843
12844 ops = &catch_exception_unhandled_breakpoint_ops;
12845 *ops = bkpt_breakpoint_ops;
12846 ops->dtor = dtor_catch_exception_unhandled;
12847 ops->allocate_location = allocate_location_catch_exception_unhandled;
12848 ops->re_set = re_set_catch_exception_unhandled;
12849 ops->check_status = check_status_catch_exception_unhandled;
12850 ops->print_it = print_it_catch_exception_unhandled;
12851 ops->print_one = print_one_catch_exception_unhandled;
12852 ops->print_mention = print_mention_catch_exception_unhandled;
12853 ops->print_recreate = print_recreate_catch_exception_unhandled;
12854
12855 ops = &catch_assert_breakpoint_ops;
12856 *ops = bkpt_breakpoint_ops;
12857 ops->dtor = dtor_catch_assert;
12858 ops->allocate_location = allocate_location_catch_assert;
12859 ops->re_set = re_set_catch_assert;
12860 ops->check_status = check_status_catch_assert;
12861 ops->print_it = print_it_catch_assert;
12862 ops->print_one = print_one_catch_assert;
12863 ops->print_mention = print_mention_catch_assert;
12864 ops->print_recreate = print_recreate_catch_assert;
12865}
12866
d2e4a39e 12867void
6c038f32 12868_initialize_ada_language (void)
14f9c5c9 12869{
6c038f32
PH
12870 add_language (&ada_language_defn);
12871
2060206e
PA
12872 initialize_ada_catchpoint_ops ();
12873
5bf03f13
JB
12874 add_prefix_cmd ("ada", no_class, set_ada_command,
12875 _("Prefix command for changing Ada-specfic settings"),
12876 &set_ada_list, "set ada ", 0, &setlist);
12877
12878 add_prefix_cmd ("ada", no_class, show_ada_command,
12879 _("Generic command for showing Ada-specific settings."),
12880 &show_ada_list, "show ada ", 0, &showlist);
12881
12882 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
12883 &trust_pad_over_xvs, _("\
12884Enable or disable an optimization trusting PAD types over XVS types"), _("\
12885Show whether an optimization trusting PAD types over XVS types is activated"),
12886 _("\
12887This is related to the encoding used by the GNAT compiler. The debugger\n\
12888should normally trust the contents of PAD types, but certain older versions\n\
12889of GNAT have a bug that sometimes causes the information in the PAD type\n\
12890to be incorrect. Turning this setting \"off\" allows the debugger to\n\
12891work around this bug. It is always safe to turn this option \"off\", but\n\
12892this incurs a slight performance penalty, so it is recommended to NOT change\n\
12893this option to \"off\" unless necessary."),
12894 NULL, NULL, &set_ada_list, &show_ada_list);
12895
9ac4176b
PA
12896 add_catch_command ("exception", _("\
12897Catch Ada exceptions, when raised.\n\
12898With an argument, catch only exceptions with the given name."),
12899 catch_ada_exception_command,
12900 NULL,
12901 CATCH_PERMANENT,
12902 CATCH_TEMPORARY);
12903 add_catch_command ("assert", _("\
12904Catch failed Ada assertions, when raised.\n\
12905With an argument, catch only exceptions with the given name."),
12906 catch_assert_command,
12907 NULL,
12908 CATCH_PERMANENT,
12909 CATCH_TEMPORARY);
12910
6c038f32 12911 varsize_limit = 65536;
6c038f32
PH
12912
12913 obstack_init (&symbol_list_obstack);
12914
12915 decoded_names_store = htab_create_alloc
12916 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
12917 NULL, xcalloc, xfree);
6b69afc4 12918
e802dbe0
JB
12919 /* Setup per-inferior data. */
12920 observer_attach_inferior_exit (ada_inferior_exit);
12921 ada_inferior_data
8e260fc0 12922 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
14f9c5c9 12923}