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