]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
Fix dates (wrong month) in the last 2 ChangeLog entries.
[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));
eca07816 584 set_value_optimized_out (result, value_optimized_out_const (val));
14f9c5c9
AS
585 return result;
586 }
587}
588
fc1a4b47
AC
589static const gdb_byte *
590cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
591{
592 if (valaddr == NULL)
593 return NULL;
594 else
595 return valaddr + offset;
596}
597
598static CORE_ADDR
ebf56fd3 599cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
600{
601 if (address == 0)
602 return 0;
d2e4a39e 603 else
14f9c5c9
AS
604 return address + offset;
605}
606
4c4b4cd2
PH
607/* Issue a warning (as for the definition of warning in utils.c, but
608 with exactly one argument rather than ...), unless the limit on the
609 number of warnings has passed during the evaluation of the current
610 expression. */
a2249542 611
77109804
AC
612/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
613 provided by "complaint". */
a0b31db1 614static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 615
14f9c5c9 616static void
a2249542 617lim_warning (const char *format, ...)
14f9c5c9 618{
a2249542 619 va_list args;
a2249542 620
5b4ee69b 621 va_start (args, format);
4c4b4cd2
PH
622 warnings_issued += 1;
623 if (warnings_issued <= warning_limit)
a2249542
MK
624 vwarning (format, args);
625
626 va_end (args);
4c4b4cd2
PH
627}
628
714e53ab
PH
629/* Issue an error if the size of an object of type T is unreasonable,
630 i.e. if it would be a bad idea to allocate a value of this type in
631 GDB. */
632
633static void
634check_size (const struct type *type)
635{
636 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 637 error (_("object size is larger than varsize-limit"));
714e53ab
PH
638}
639
0963b4bd 640/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 641static LONGEST
c3e5cd34 642max_of_size (int size)
4c4b4cd2 643{
76a01679 644 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 645
76a01679 646 return top_bit | (top_bit - 1);
4c4b4cd2
PH
647}
648
0963b4bd 649/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 650static LONGEST
c3e5cd34 651min_of_size (int size)
4c4b4cd2 652{
c3e5cd34 653 return -max_of_size (size) - 1;
4c4b4cd2
PH
654}
655
0963b4bd 656/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 657static ULONGEST
c3e5cd34 658umax_of_size (int size)
4c4b4cd2 659{
76a01679 660 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 661
76a01679 662 return top_bit | (top_bit - 1);
4c4b4cd2
PH
663}
664
0963b4bd 665/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
666static LONGEST
667max_of_type (struct type *t)
4c4b4cd2 668{
c3e5cd34
PH
669 if (TYPE_UNSIGNED (t))
670 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
671 else
672 return max_of_size (TYPE_LENGTH (t));
673}
674
0963b4bd 675/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
676static LONGEST
677min_of_type (struct type *t)
678{
679 if (TYPE_UNSIGNED (t))
680 return 0;
681 else
682 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
683}
684
685/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
686LONGEST
687ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 688{
76a01679 689 switch (TYPE_CODE (type))
4c4b4cd2
PH
690 {
691 case TYPE_CODE_RANGE:
690cc4eb 692 return TYPE_HIGH_BOUND (type);
4c4b4cd2 693 case TYPE_CODE_ENUM:
14e75d8e 694 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
695 case TYPE_CODE_BOOL:
696 return 1;
697 case TYPE_CODE_CHAR:
76a01679 698 case TYPE_CODE_INT:
690cc4eb 699 return max_of_type (type);
4c4b4cd2 700 default:
43bbcdc2 701 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
702 }
703}
704
14e75d8e 705/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
706LONGEST
707ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 708{
76a01679 709 switch (TYPE_CODE (type))
4c4b4cd2
PH
710 {
711 case TYPE_CODE_RANGE:
690cc4eb 712 return TYPE_LOW_BOUND (type);
4c4b4cd2 713 case TYPE_CODE_ENUM:
14e75d8e 714 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
715 case TYPE_CODE_BOOL:
716 return 0;
717 case TYPE_CODE_CHAR:
76a01679 718 case TYPE_CODE_INT:
690cc4eb 719 return min_of_type (type);
4c4b4cd2 720 default:
43bbcdc2 721 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
722 }
723}
724
725/* The identity on non-range types. For range types, the underlying
76a01679 726 non-range scalar type. */
4c4b4cd2
PH
727
728static struct type *
18af8284 729get_base_type (struct type *type)
4c4b4cd2
PH
730{
731 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
732 {
76a01679
JB
733 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
734 return type;
4c4b4cd2
PH
735 type = TYPE_TARGET_TYPE (type);
736 }
737 return type;
14f9c5c9 738}
41246937
JB
739
740/* Return a decoded version of the given VALUE. This means returning
741 a value whose type is obtained by applying all the GNAT-specific
742 encondings, making the resulting type a static but standard description
743 of the initial type. */
744
745struct value *
746ada_get_decoded_value (struct value *value)
747{
748 struct type *type = ada_check_typedef (value_type (value));
749
750 if (ada_is_array_descriptor_type (type)
751 || (ada_is_constrained_packed_array_type (type)
752 && TYPE_CODE (type) != TYPE_CODE_PTR))
753 {
754 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
755 value = ada_coerce_to_simple_array_ptr (value);
756 else
757 value = ada_coerce_to_simple_array (value);
758 }
759 else
760 value = ada_to_fixed_value (value);
761
762 return value;
763}
764
765/* Same as ada_get_decoded_value, but with the given TYPE.
766 Because there is no associated actual value for this type,
767 the resulting type might be a best-effort approximation in
768 the case of dynamic types. */
769
770struct type *
771ada_get_decoded_type (struct type *type)
772{
773 type = to_static_fixed_type (type);
774 if (ada_is_constrained_packed_array_type (type))
775 type = ada_coerce_to_simple_array_type (type);
776 return type;
777}
778
4c4b4cd2 779\f
76a01679 780
4c4b4cd2 781 /* Language Selection */
14f9c5c9
AS
782
783/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 784 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 785
14f9c5c9 786enum language
ccefe4c4 787ada_update_initial_language (enum language lang)
14f9c5c9 788{
d2e4a39e 789 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
4c4b4cd2
PH
790 (struct objfile *) NULL) != NULL)
791 return language_ada;
14f9c5c9
AS
792
793 return lang;
794}
96d887e8
PH
795
796/* If the main procedure is written in Ada, then return its name.
797 The result is good until the next call. Return NULL if the main
798 procedure doesn't appear to be in Ada. */
799
800char *
801ada_main_name (void)
802{
803 struct minimal_symbol *msym;
f9bc20b9 804 static char *main_program_name = NULL;
6c038f32 805
96d887e8
PH
806 /* For Ada, the name of the main procedure is stored in a specific
807 string constant, generated by the binder. Look for that symbol,
808 extract its address, and then read that string. If we didn't find
809 that string, then most probably the main procedure is not written
810 in Ada. */
811 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
812
813 if (msym != NULL)
814 {
f9bc20b9
JB
815 CORE_ADDR main_program_name_addr;
816 int err_code;
817
96d887e8
PH
818 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
819 if (main_program_name_addr == 0)
323e0a4a 820 error (_("Invalid address for Ada main program name."));
96d887e8 821
f9bc20b9
JB
822 xfree (main_program_name);
823 target_read_string (main_program_name_addr, &main_program_name,
824 1024, &err_code);
825
826 if (err_code != 0)
827 return NULL;
96d887e8
PH
828 return main_program_name;
829 }
830
831 /* The main procedure doesn't seem to be in Ada. */
832 return NULL;
833}
14f9c5c9 834\f
4c4b4cd2 835 /* Symbols */
d2e4a39e 836
4c4b4cd2
PH
837/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
838 of NULLs. */
14f9c5c9 839
d2e4a39e
AS
840const struct ada_opname_map ada_opname_table[] = {
841 {"Oadd", "\"+\"", BINOP_ADD},
842 {"Osubtract", "\"-\"", BINOP_SUB},
843 {"Omultiply", "\"*\"", BINOP_MUL},
844 {"Odivide", "\"/\"", BINOP_DIV},
845 {"Omod", "\"mod\"", BINOP_MOD},
846 {"Orem", "\"rem\"", BINOP_REM},
847 {"Oexpon", "\"**\"", BINOP_EXP},
848 {"Olt", "\"<\"", BINOP_LESS},
849 {"Ole", "\"<=\"", BINOP_LEQ},
850 {"Ogt", "\">\"", BINOP_GTR},
851 {"Oge", "\">=\"", BINOP_GEQ},
852 {"Oeq", "\"=\"", BINOP_EQUAL},
853 {"One", "\"/=\"", BINOP_NOTEQUAL},
854 {"Oand", "\"and\"", BINOP_BITWISE_AND},
855 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
856 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
857 {"Oconcat", "\"&\"", BINOP_CONCAT},
858 {"Oabs", "\"abs\"", UNOP_ABS},
859 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
860 {"Oadd", "\"+\"", UNOP_PLUS},
861 {"Osubtract", "\"-\"", UNOP_NEG},
862 {NULL, NULL}
14f9c5c9
AS
863};
864
4c4b4cd2
PH
865/* The "encoded" form of DECODED, according to GNAT conventions.
866 The result is valid until the next call to ada_encode. */
867
14f9c5c9 868char *
4c4b4cd2 869ada_encode (const char *decoded)
14f9c5c9 870{
4c4b4cd2
PH
871 static char *encoding_buffer = NULL;
872 static size_t encoding_buffer_size = 0;
d2e4a39e 873 const char *p;
14f9c5c9 874 int k;
d2e4a39e 875
4c4b4cd2 876 if (decoded == NULL)
14f9c5c9
AS
877 return NULL;
878
4c4b4cd2
PH
879 GROW_VECT (encoding_buffer, encoding_buffer_size,
880 2 * strlen (decoded) + 10);
14f9c5c9
AS
881
882 k = 0;
4c4b4cd2 883 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 884 {
cdc7bb92 885 if (*p == '.')
4c4b4cd2
PH
886 {
887 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
888 k += 2;
889 }
14f9c5c9 890 else if (*p == '"')
4c4b4cd2
PH
891 {
892 const struct ada_opname_map *mapping;
893
894 for (mapping = ada_opname_table;
1265e4aa
JB
895 mapping->encoded != NULL
896 && strncmp (mapping->decoded, p,
897 strlen (mapping->decoded)) != 0; mapping += 1)
4c4b4cd2
PH
898 ;
899 if (mapping->encoded == NULL)
323e0a4a 900 error (_("invalid Ada operator name: %s"), p);
4c4b4cd2
PH
901 strcpy (encoding_buffer + k, mapping->encoded);
902 k += strlen (mapping->encoded);
903 break;
904 }
d2e4a39e 905 else
4c4b4cd2
PH
906 {
907 encoding_buffer[k] = *p;
908 k += 1;
909 }
14f9c5c9
AS
910 }
911
4c4b4cd2
PH
912 encoding_buffer[k] = '\0';
913 return encoding_buffer;
14f9c5c9
AS
914}
915
916/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
917 quotes, unfolded, but with the quotes stripped away. Result good
918 to next call. */
919
d2e4a39e
AS
920char *
921ada_fold_name (const char *name)
14f9c5c9 922{
d2e4a39e 923 static char *fold_buffer = NULL;
14f9c5c9
AS
924 static size_t fold_buffer_size = 0;
925
926 int len = strlen (name);
d2e4a39e 927 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
928
929 if (name[0] == '\'')
930 {
d2e4a39e
AS
931 strncpy (fold_buffer, name + 1, len - 2);
932 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
933 }
934 else
935 {
936 int i;
5b4ee69b 937
14f9c5c9 938 for (i = 0; i <= len; i += 1)
4c4b4cd2 939 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
940 }
941
942 return fold_buffer;
943}
944
529cad9c
PH
945/* Return nonzero if C is either a digit or a lowercase alphabet character. */
946
947static int
948is_lower_alphanum (const char c)
949{
950 return (isdigit (c) || (isalpha (c) && islower (c)));
951}
952
c90092fe
JB
953/* ENCODED is the linkage name of a symbol and LEN contains its length.
954 This function saves in LEN the length of that same symbol name but
955 without either of these suffixes:
29480c32
JB
956 . .{DIGIT}+
957 . ${DIGIT}+
958 . ___{DIGIT}+
959 . __{DIGIT}+.
c90092fe 960
29480c32
JB
961 These are suffixes introduced by the compiler for entities such as
962 nested subprogram for instance, in order to avoid name clashes.
963 They do not serve any purpose for the debugger. */
964
965static void
966ada_remove_trailing_digits (const char *encoded, int *len)
967{
968 if (*len > 1 && isdigit (encoded[*len - 1]))
969 {
970 int i = *len - 2;
5b4ee69b 971
29480c32
JB
972 while (i > 0 && isdigit (encoded[i]))
973 i--;
974 if (i >= 0 && encoded[i] == '.')
975 *len = i;
976 else if (i >= 0 && encoded[i] == '$')
977 *len = i;
978 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
979 *len = i - 2;
980 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
981 *len = i - 1;
982 }
983}
984
985/* Remove the suffix introduced by the compiler for protected object
986 subprograms. */
987
988static void
989ada_remove_po_subprogram_suffix (const char *encoded, int *len)
990{
991 /* Remove trailing N. */
992
993 /* Protected entry subprograms are broken into two
994 separate subprograms: The first one is unprotected, and has
995 a 'N' suffix; the second is the protected version, and has
0963b4bd 996 the 'P' suffix. The second calls the first one after handling
29480c32
JB
997 the protection. Since the P subprograms are internally generated,
998 we leave these names undecoded, giving the user a clue that this
999 entity is internal. */
1000
1001 if (*len > 1
1002 && encoded[*len - 1] == 'N'
1003 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1004 *len = *len - 1;
1005}
1006
69fadcdf
JB
1007/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1008
1009static void
1010ada_remove_Xbn_suffix (const char *encoded, int *len)
1011{
1012 int i = *len - 1;
1013
1014 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1015 i--;
1016
1017 if (encoded[i] != 'X')
1018 return;
1019
1020 if (i == 0)
1021 return;
1022
1023 if (isalnum (encoded[i-1]))
1024 *len = i;
1025}
1026
29480c32
JB
1027/* If ENCODED follows the GNAT entity encoding conventions, then return
1028 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1029 replaced by ENCODED.
14f9c5c9 1030
4c4b4cd2 1031 The resulting string is valid until the next call of ada_decode.
29480c32 1032 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1033 is returned. */
1034
1035const char *
1036ada_decode (const char *encoded)
14f9c5c9
AS
1037{
1038 int i, j;
1039 int len0;
d2e4a39e 1040 const char *p;
4c4b4cd2 1041 char *decoded;
14f9c5c9 1042 int at_start_name;
4c4b4cd2
PH
1043 static char *decoding_buffer = NULL;
1044 static size_t decoding_buffer_size = 0;
d2e4a39e 1045
29480c32
JB
1046 /* The name of the Ada main procedure starts with "_ada_".
1047 This prefix is not part of the decoded name, so skip this part
1048 if we see this prefix. */
4c4b4cd2
PH
1049 if (strncmp (encoded, "_ada_", 5) == 0)
1050 encoded += 5;
14f9c5c9 1051
29480c32
JB
1052 /* If the name starts with '_', then it is not a properly encoded
1053 name, so do not attempt to decode it. Similarly, if the name
1054 starts with '<', the name should not be decoded. */
4c4b4cd2 1055 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1056 goto Suppress;
1057
4c4b4cd2 1058 len0 = strlen (encoded);
4c4b4cd2 1059
29480c32
JB
1060 ada_remove_trailing_digits (encoded, &len0);
1061 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1062
4c4b4cd2
PH
1063 /* Remove the ___X.* suffix if present. Do not forget to verify that
1064 the suffix is located before the current "end" of ENCODED. We want
1065 to avoid re-matching parts of ENCODED that have previously been
1066 marked as discarded (by decrementing LEN0). */
1067 p = strstr (encoded, "___");
1068 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1069 {
1070 if (p[3] == 'X')
4c4b4cd2 1071 len0 = p - encoded;
14f9c5c9 1072 else
4c4b4cd2 1073 goto Suppress;
14f9c5c9 1074 }
4c4b4cd2 1075
29480c32
JB
1076 /* Remove any trailing TKB suffix. It tells us that this symbol
1077 is for the body of a task, but that information does not actually
1078 appear in the decoded name. */
1079
4c4b4cd2 1080 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
14f9c5c9 1081 len0 -= 3;
76a01679 1082
a10967fa
JB
1083 /* Remove any trailing TB suffix. The TB suffix is slightly different
1084 from the TKB suffix because it is used for non-anonymous task
1085 bodies. */
1086
1087 if (len0 > 2 && strncmp (encoded + len0 - 2, "TB", 2) == 0)
1088 len0 -= 2;
1089
29480c32
JB
1090 /* Remove trailing "B" suffixes. */
1091 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1092
4c4b4cd2 1093 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
14f9c5c9
AS
1094 len0 -= 1;
1095
4c4b4cd2 1096 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1097
4c4b4cd2
PH
1098 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1099 decoded = decoding_buffer;
14f9c5c9 1100
29480c32
JB
1101 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1102
4c4b4cd2 1103 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1104 {
4c4b4cd2
PH
1105 i = len0 - 2;
1106 while ((i >= 0 && isdigit (encoded[i]))
1107 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1108 i -= 1;
1109 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1110 len0 = i - 1;
1111 else if (encoded[i] == '$')
1112 len0 = i;
d2e4a39e 1113 }
14f9c5c9 1114
29480c32
JB
1115 /* The first few characters that are not alphabetic are not part
1116 of any encoding we use, so we can copy them over verbatim. */
1117
4c4b4cd2
PH
1118 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1119 decoded[j] = encoded[i];
14f9c5c9
AS
1120
1121 at_start_name = 1;
1122 while (i < len0)
1123 {
29480c32 1124 /* Is this a symbol function? */
4c4b4cd2
PH
1125 if (at_start_name && encoded[i] == 'O')
1126 {
1127 int k;
5b4ee69b 1128
4c4b4cd2
PH
1129 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1130 {
1131 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1132 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1133 op_len - 1) == 0)
1134 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1135 {
1136 strcpy (decoded + j, ada_opname_table[k].decoded);
1137 at_start_name = 0;
1138 i += op_len;
1139 j += strlen (ada_opname_table[k].decoded);
1140 break;
1141 }
1142 }
1143 if (ada_opname_table[k].encoded != NULL)
1144 continue;
1145 }
14f9c5c9
AS
1146 at_start_name = 0;
1147
529cad9c
PH
1148 /* Replace "TK__" with "__", which will eventually be translated
1149 into "." (just below). */
1150
4c4b4cd2
PH
1151 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
1152 i += 2;
529cad9c 1153
29480c32
JB
1154 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1155 be translated into "." (just below). These are internal names
1156 generated for anonymous blocks inside which our symbol is nested. */
1157
1158 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1159 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1160 && isdigit (encoded [i+4]))
1161 {
1162 int k = i + 5;
1163
1164 while (k < len0 && isdigit (encoded[k]))
1165 k++; /* Skip any extra digit. */
1166
1167 /* Double-check that the "__B_{DIGITS}+" sequence we found
1168 is indeed followed by "__". */
1169 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1170 i = k;
1171 }
1172
529cad9c
PH
1173 /* Remove _E{DIGITS}+[sb] */
1174
1175 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1176 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1177 one implements the actual entry code, and has a suffix following
1178 the convention above; the second one implements the barrier and
1179 uses the same convention as above, except that the 'E' is replaced
1180 by a 'B'.
1181
1182 Just as above, we do not decode the name of barrier functions
1183 to give the user a clue that the code he is debugging has been
1184 internally generated. */
1185
1186 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1187 && isdigit (encoded[i+2]))
1188 {
1189 int k = i + 3;
1190
1191 while (k < len0 && isdigit (encoded[k]))
1192 k++;
1193
1194 if (k < len0
1195 && (encoded[k] == 'b' || encoded[k] == 's'))
1196 {
1197 k++;
1198 /* Just as an extra precaution, make sure that if this
1199 suffix is followed by anything else, it is a '_'.
1200 Otherwise, we matched this sequence by accident. */
1201 if (k == len0
1202 || (k < len0 && encoded[k] == '_'))
1203 i = k;
1204 }
1205 }
1206
1207 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1208 the GNAT front-end in protected object subprograms. */
1209
1210 if (i < len0 + 3
1211 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1212 {
1213 /* Backtrack a bit up until we reach either the begining of
1214 the encoded name, or "__". Make sure that we only find
1215 digits or lowercase characters. */
1216 const char *ptr = encoded + i - 1;
1217
1218 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1219 ptr--;
1220 if (ptr < encoded
1221 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1222 i++;
1223 }
1224
4c4b4cd2
PH
1225 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1226 {
29480c32
JB
1227 /* This is a X[bn]* sequence not separated from the previous
1228 part of the name with a non-alpha-numeric character (in other
1229 words, immediately following an alpha-numeric character), then
1230 verify that it is placed at the end of the encoded name. If
1231 not, then the encoding is not valid and we should abort the
1232 decoding. Otherwise, just skip it, it is used in body-nested
1233 package names. */
4c4b4cd2
PH
1234 do
1235 i += 1;
1236 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1237 if (i < len0)
1238 goto Suppress;
1239 }
cdc7bb92 1240 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1241 {
29480c32 1242 /* Replace '__' by '.'. */
4c4b4cd2
PH
1243 decoded[j] = '.';
1244 at_start_name = 1;
1245 i += 2;
1246 j += 1;
1247 }
14f9c5c9 1248 else
4c4b4cd2 1249 {
29480c32
JB
1250 /* It's a character part of the decoded name, so just copy it
1251 over. */
4c4b4cd2
PH
1252 decoded[j] = encoded[i];
1253 i += 1;
1254 j += 1;
1255 }
14f9c5c9 1256 }
4c4b4cd2 1257 decoded[j] = '\000';
14f9c5c9 1258
29480c32
JB
1259 /* Decoded names should never contain any uppercase character.
1260 Double-check this, and abort the decoding if we find one. */
1261
4c4b4cd2
PH
1262 for (i = 0; decoded[i] != '\0'; i += 1)
1263 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1264 goto Suppress;
1265
4c4b4cd2
PH
1266 if (strcmp (decoded, encoded) == 0)
1267 return encoded;
1268 else
1269 return decoded;
14f9c5c9
AS
1270
1271Suppress:
4c4b4cd2
PH
1272 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1273 decoded = decoding_buffer;
1274 if (encoded[0] == '<')
1275 strcpy (decoded, encoded);
14f9c5c9 1276 else
88c15c34 1277 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1278 return decoded;
1279
1280}
1281
1282/* Table for keeping permanent unique copies of decoded names. Once
1283 allocated, names in this table are never released. While this is a
1284 storage leak, it should not be significant unless there are massive
1285 changes in the set of decoded names in successive versions of a
1286 symbol table loaded during a single session. */
1287static struct htab *decoded_names_store;
1288
1289/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1290 in the language-specific part of GSYMBOL, if it has not been
1291 previously computed. Tries to save the decoded name in the same
1292 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1293 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1294 GSYMBOL).
4c4b4cd2
PH
1295 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1296 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1297 when a decoded name is cached in it. */
4c4b4cd2 1298
45e6c716 1299const char *
f85f34ed 1300ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1301{
f85f34ed
TT
1302 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1303 const char **resultp =
1304 &gsymbol->language_specific.mangled_lang.demangled_name;
5b4ee69b 1305
f85f34ed 1306 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1307 {
1308 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1309 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1310
f85f34ed 1311 gsymbol->ada_mangled = 1;
5b4ee69b 1312
f85f34ed
TT
1313 if (obstack != NULL)
1314 *resultp = obstack_copy0 (obstack, decoded, strlen (decoded));
1315 else
76a01679 1316 {
f85f34ed
TT
1317 /* Sometimes, we can't find a corresponding objfile, in
1318 which case, we put the result on the heap. Since we only
1319 decode when needed, we hope this usually does not cause a
1320 significant memory leak (FIXME). */
1321
76a01679
JB
1322 char **slot = (char **) htab_find_slot (decoded_names_store,
1323 decoded, INSERT);
5b4ee69b 1324
76a01679
JB
1325 if (*slot == NULL)
1326 *slot = xstrdup (decoded);
1327 *resultp = *slot;
1328 }
4c4b4cd2 1329 }
14f9c5c9 1330
4c4b4cd2
PH
1331 return *resultp;
1332}
76a01679 1333
2c0b251b 1334static char *
76a01679 1335ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1336{
1337 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1338}
1339
1340/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
4c4b4cd2
PH
1341 suffixes that encode debugging information or leading _ada_ on
1342 SYM_NAME (see is_name_suffix commentary for the debugging
1343 information that is ignored). If WILD, then NAME need only match a
1344 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1345 either argument is NULL. */
14f9c5c9 1346
2c0b251b 1347static int
40658b94 1348match_name (const char *sym_name, const char *name, int wild)
14f9c5c9
AS
1349{
1350 if (sym_name == NULL || name == NULL)
1351 return 0;
1352 else if (wild)
73589123 1353 return wild_match (sym_name, name) == 0;
d2e4a39e
AS
1354 else
1355 {
1356 int len_name = strlen (name);
5b4ee69b 1357
4c4b4cd2
PH
1358 return (strncmp (sym_name, name, len_name) == 0
1359 && is_name_suffix (sym_name + len_name))
1360 || (strncmp (sym_name, "_ada_", 5) == 0
1361 && strncmp (sym_name + 5, name, len_name) == 0
1362 && is_name_suffix (sym_name + len_name + 5));
d2e4a39e 1363 }
14f9c5c9 1364}
14f9c5c9 1365\f
d2e4a39e 1366
4c4b4cd2 1367 /* Arrays */
14f9c5c9 1368
28c85d6c
JB
1369/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1370 generated by the GNAT compiler to describe the index type used
1371 for each dimension of an array, check whether it follows the latest
1372 known encoding. If not, fix it up to conform to the latest encoding.
1373 Otherwise, do nothing. This function also does nothing if
1374 INDEX_DESC_TYPE is NULL.
1375
1376 The GNAT encoding used to describle the array index type evolved a bit.
1377 Initially, the information would be provided through the name of each
1378 field of the structure type only, while the type of these fields was
1379 described as unspecified and irrelevant. The debugger was then expected
1380 to perform a global type lookup using the name of that field in order
1381 to get access to the full index type description. Because these global
1382 lookups can be very expensive, the encoding was later enhanced to make
1383 the global lookup unnecessary by defining the field type as being
1384 the full index type description.
1385
1386 The purpose of this routine is to allow us to support older versions
1387 of the compiler by detecting the use of the older encoding, and by
1388 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1389 we essentially replace each field's meaningless type by the associated
1390 index subtype). */
1391
1392void
1393ada_fixup_array_indexes_type (struct type *index_desc_type)
1394{
1395 int i;
1396
1397 if (index_desc_type == NULL)
1398 return;
1399 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1400
1401 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1402 to check one field only, no need to check them all). If not, return
1403 now.
1404
1405 If our INDEX_DESC_TYPE was generated using the older encoding,
1406 the field type should be a meaningless integer type whose name
1407 is not equal to the field name. */
1408 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1409 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1410 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1411 return;
1412
1413 /* Fixup each field of INDEX_DESC_TYPE. */
1414 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1415 {
0d5cff50 1416 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1417 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1418
1419 if (raw_type)
1420 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1421 }
1422}
1423
4c4b4cd2 1424/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1425
d2e4a39e
AS
1426static char *bound_name[] = {
1427 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1428 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1429};
1430
1431/* Maximum number of array dimensions we are prepared to handle. */
1432
4c4b4cd2 1433#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1434
14f9c5c9 1435
4c4b4cd2
PH
1436/* The desc_* routines return primitive portions of array descriptors
1437 (fat pointers). */
14f9c5c9
AS
1438
1439/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1440 level of indirection, if needed. */
1441
d2e4a39e
AS
1442static struct type *
1443desc_base_type (struct type *type)
14f9c5c9
AS
1444{
1445 if (type == NULL)
1446 return NULL;
61ee279c 1447 type = ada_check_typedef (type);
720d1a40
JB
1448 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1449 type = ada_typedef_target_type (type);
1450
1265e4aa
JB
1451 if (type != NULL
1452 && (TYPE_CODE (type) == TYPE_CODE_PTR
1453 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1454 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1455 else
1456 return type;
1457}
1458
4c4b4cd2
PH
1459/* True iff TYPE indicates a "thin" array pointer type. */
1460
14f9c5c9 1461static int
d2e4a39e 1462is_thin_pntr (struct type *type)
14f9c5c9 1463{
d2e4a39e 1464 return
14f9c5c9
AS
1465 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1466 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1467}
1468
4c4b4cd2
PH
1469/* The descriptor type for thin pointer type TYPE. */
1470
d2e4a39e
AS
1471static struct type *
1472thin_descriptor_type (struct type *type)
14f9c5c9 1473{
d2e4a39e 1474 struct type *base_type = desc_base_type (type);
5b4ee69b 1475
14f9c5c9
AS
1476 if (base_type == NULL)
1477 return NULL;
1478 if (is_suffix (ada_type_name (base_type), "___XVE"))
1479 return base_type;
d2e4a39e 1480 else
14f9c5c9 1481 {
d2e4a39e 1482 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1483
14f9c5c9 1484 if (alt_type == NULL)
4c4b4cd2 1485 return base_type;
14f9c5c9 1486 else
4c4b4cd2 1487 return alt_type;
14f9c5c9
AS
1488 }
1489}
1490
4c4b4cd2
PH
1491/* A pointer to the array data for thin-pointer value VAL. */
1492
d2e4a39e
AS
1493static struct value *
1494thin_data_pntr (struct value *val)
14f9c5c9 1495{
828292f2 1496 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1497 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1498
556bdfd4
UW
1499 data_type = lookup_pointer_type (data_type);
1500
14f9c5c9 1501 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1502 return value_cast (data_type, value_copy (val));
d2e4a39e 1503 else
42ae5230 1504 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1505}
1506
4c4b4cd2
PH
1507/* True iff TYPE indicates a "thick" array pointer type. */
1508
14f9c5c9 1509static int
d2e4a39e 1510is_thick_pntr (struct type *type)
14f9c5c9
AS
1511{
1512 type = desc_base_type (type);
1513 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1514 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1515}
1516
4c4b4cd2
PH
1517/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1518 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1519
d2e4a39e
AS
1520static struct type *
1521desc_bounds_type (struct type *type)
14f9c5c9 1522{
d2e4a39e 1523 struct type *r;
14f9c5c9
AS
1524
1525 type = desc_base_type (type);
1526
1527 if (type == NULL)
1528 return NULL;
1529 else if (is_thin_pntr (type))
1530 {
1531 type = thin_descriptor_type (type);
1532 if (type == NULL)
4c4b4cd2 1533 return NULL;
14f9c5c9
AS
1534 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1535 if (r != NULL)
61ee279c 1536 return ada_check_typedef (r);
14f9c5c9
AS
1537 }
1538 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1539 {
1540 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1541 if (r != NULL)
61ee279c 1542 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1543 }
1544 return NULL;
1545}
1546
1547/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1548 one, a pointer to its bounds data. Otherwise NULL. */
1549
d2e4a39e
AS
1550static struct value *
1551desc_bounds (struct value *arr)
14f9c5c9 1552{
df407dfe 1553 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1554
d2e4a39e 1555 if (is_thin_pntr (type))
14f9c5c9 1556 {
d2e4a39e 1557 struct type *bounds_type =
4c4b4cd2 1558 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1559 LONGEST addr;
1560
4cdfadb1 1561 if (bounds_type == NULL)
323e0a4a 1562 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1563
1564 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1565 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1566 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1567 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1568 addr = value_as_long (arr);
d2e4a39e 1569 else
42ae5230 1570 addr = value_address (arr);
14f9c5c9 1571
d2e4a39e 1572 return
4c4b4cd2
PH
1573 value_from_longest (lookup_pointer_type (bounds_type),
1574 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1575 }
1576
1577 else if (is_thick_pntr (type))
05e522ef
JB
1578 {
1579 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1580 _("Bad GNAT array descriptor"));
1581 struct type *p_bounds_type = value_type (p_bounds);
1582
1583 if (p_bounds_type
1584 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1585 {
1586 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1587
1588 if (TYPE_STUB (target_type))
1589 p_bounds = value_cast (lookup_pointer_type
1590 (ada_check_typedef (target_type)),
1591 p_bounds);
1592 }
1593 else
1594 error (_("Bad GNAT array descriptor"));
1595
1596 return p_bounds;
1597 }
14f9c5c9
AS
1598 else
1599 return NULL;
1600}
1601
4c4b4cd2
PH
1602/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1603 position of the field containing the address of the bounds data. */
1604
14f9c5c9 1605static int
d2e4a39e 1606fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1607{
1608 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1609}
1610
1611/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1612 size of the field containing the address of the bounds data. */
1613
14f9c5c9 1614static int
d2e4a39e 1615fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1616{
1617 type = desc_base_type (type);
1618
d2e4a39e 1619 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1620 return TYPE_FIELD_BITSIZE (type, 1);
1621 else
61ee279c 1622 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1623}
1624
4c4b4cd2 1625/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1626 pointer to one, the type of its array data (a array-with-no-bounds type);
1627 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1628 data. */
4c4b4cd2 1629
d2e4a39e 1630static struct type *
556bdfd4 1631desc_data_target_type (struct type *type)
14f9c5c9
AS
1632{
1633 type = desc_base_type (type);
1634
4c4b4cd2 1635 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1636 if (is_thin_pntr (type))
556bdfd4 1637 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1638 else if (is_thick_pntr (type))
556bdfd4
UW
1639 {
1640 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1641
1642 if (data_type
1643 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1644 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1645 }
1646
1647 return NULL;
14f9c5c9
AS
1648}
1649
1650/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1651 its array data. */
4c4b4cd2 1652
d2e4a39e
AS
1653static struct value *
1654desc_data (struct value *arr)
14f9c5c9 1655{
df407dfe 1656 struct type *type = value_type (arr);
5b4ee69b 1657
14f9c5c9
AS
1658 if (is_thin_pntr (type))
1659 return thin_data_pntr (arr);
1660 else if (is_thick_pntr (type))
d2e4a39e 1661 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1662 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1663 else
1664 return NULL;
1665}
1666
1667
1668/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1669 position of the field containing the address of the data. */
1670
14f9c5c9 1671static int
d2e4a39e 1672fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1673{
1674 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1675}
1676
1677/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1678 size of the field containing the address of the data. */
1679
14f9c5c9 1680static int
d2e4a39e 1681fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1682{
1683 type = desc_base_type (type);
1684
1685 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1686 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1687 else
14f9c5c9
AS
1688 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1689}
1690
4c4b4cd2 1691/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1692 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1693 bound, if WHICH is 1. The first bound is I=1. */
1694
d2e4a39e
AS
1695static struct value *
1696desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1697{
d2e4a39e 1698 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1699 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1700}
1701
1702/* If BOUNDS is an array-bounds structure type, return the bit position
1703 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1704 bound, if WHICH is 1. The first bound is I=1. */
1705
14f9c5c9 1706static int
d2e4a39e 1707desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1708{
d2e4a39e 1709 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1710}
1711
1712/* If BOUNDS is an array-bounds structure type, return the bit field size
1713 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1714 bound, if WHICH is 1. The first bound is I=1. */
1715
76a01679 1716static int
d2e4a39e 1717desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1718{
1719 type = desc_base_type (type);
1720
d2e4a39e
AS
1721 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1722 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1723 else
1724 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1725}
1726
1727/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1728 Ith bound (numbering from 1). Otherwise, NULL. */
1729
d2e4a39e
AS
1730static struct type *
1731desc_index_type (struct type *type, int i)
14f9c5c9
AS
1732{
1733 type = desc_base_type (type);
1734
1735 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1736 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1737 else
14f9c5c9
AS
1738 return NULL;
1739}
1740
4c4b4cd2
PH
1741/* The number of index positions in the array-bounds type TYPE.
1742 Return 0 if TYPE is NULL. */
1743
14f9c5c9 1744static int
d2e4a39e 1745desc_arity (struct type *type)
14f9c5c9
AS
1746{
1747 type = desc_base_type (type);
1748
1749 if (type != NULL)
1750 return TYPE_NFIELDS (type) / 2;
1751 return 0;
1752}
1753
4c4b4cd2
PH
1754/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1755 an array descriptor type (representing an unconstrained array
1756 type). */
1757
76a01679
JB
1758static int
1759ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1760{
1761 if (type == NULL)
1762 return 0;
61ee279c 1763 type = ada_check_typedef (type);
4c4b4cd2 1764 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1765 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1766}
1767
52ce6436 1768/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1769 * to one. */
52ce6436 1770
2c0b251b 1771static int
52ce6436
PH
1772ada_is_array_type (struct type *type)
1773{
1774 while (type != NULL
1775 && (TYPE_CODE (type) == TYPE_CODE_PTR
1776 || TYPE_CODE (type) == TYPE_CODE_REF))
1777 type = TYPE_TARGET_TYPE (type);
1778 return ada_is_direct_array_type (type);
1779}
1780
4c4b4cd2 1781/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1782
14f9c5c9 1783int
4c4b4cd2 1784ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1785{
1786 if (type == NULL)
1787 return 0;
61ee279c 1788 type = ada_check_typedef (type);
14f9c5c9 1789 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1790 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1791 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1792 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1793}
1794
4c4b4cd2
PH
1795/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1796
14f9c5c9 1797int
4c4b4cd2 1798ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1799{
556bdfd4 1800 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1801
1802 if (type == NULL)
1803 return 0;
61ee279c 1804 type = ada_check_typedef (type);
556bdfd4
UW
1805 return (data_type != NULL
1806 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1807 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1808}
1809
1810/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1811 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1812 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1813 is still needed. */
1814
14f9c5c9 1815int
ebf56fd3 1816ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1817{
d2e4a39e 1818 return
14f9c5c9
AS
1819 type != NULL
1820 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1821 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1822 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1823 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1824}
1825
1826
4c4b4cd2 1827/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1828 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1829 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1830 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1831 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1832 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1833 a descriptor. */
d2e4a39e
AS
1834struct type *
1835ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1836{
ad82864c
JB
1837 if (ada_is_constrained_packed_array_type (value_type (arr)))
1838 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1839
df407dfe
AC
1840 if (!ada_is_array_descriptor_type (value_type (arr)))
1841 return value_type (arr);
d2e4a39e
AS
1842
1843 if (!bounds)
ad82864c
JB
1844 {
1845 struct type *array_type =
1846 ada_check_typedef (desc_data_target_type (value_type (arr)));
1847
1848 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1849 TYPE_FIELD_BITSIZE (array_type, 0) =
1850 decode_packed_array_bitsize (value_type (arr));
1851
1852 return array_type;
1853 }
14f9c5c9
AS
1854 else
1855 {
d2e4a39e 1856 struct type *elt_type;
14f9c5c9 1857 int arity;
d2e4a39e 1858 struct value *descriptor;
14f9c5c9 1859
df407dfe
AC
1860 elt_type = ada_array_element_type (value_type (arr), -1);
1861 arity = ada_array_arity (value_type (arr));
14f9c5c9 1862
d2e4a39e 1863 if (elt_type == NULL || arity == 0)
df407dfe 1864 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
1865
1866 descriptor = desc_bounds (arr);
d2e4a39e 1867 if (value_as_long (descriptor) == 0)
4c4b4cd2 1868 return NULL;
d2e4a39e 1869 while (arity > 0)
4c4b4cd2 1870 {
e9bb382b
UW
1871 struct type *range_type = alloc_type_copy (value_type (arr));
1872 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
1873 struct value *low = desc_one_bound (descriptor, arity, 0);
1874 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 1875
5b4ee69b 1876 arity -= 1;
df407dfe 1877 create_range_type (range_type, value_type (low),
529cad9c
PH
1878 longest_to_int (value_as_long (low)),
1879 longest_to_int (value_as_long (high)));
4c4b4cd2 1880 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
1881
1882 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
1883 {
1884 /* We need to store the element packed bitsize, as well as
1885 recompute the array size, because it was previously
1886 computed based on the unpacked element size. */
1887 LONGEST lo = value_as_long (low);
1888 LONGEST hi = value_as_long (high);
1889
1890 TYPE_FIELD_BITSIZE (elt_type, 0) =
1891 decode_packed_array_bitsize (value_type (arr));
1892 /* If the array has no element, then the size is already
1893 zero, and does not need to be recomputed. */
1894 if (lo < hi)
1895 {
1896 int array_bitsize =
1897 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1898
1899 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
1900 }
1901 }
4c4b4cd2 1902 }
14f9c5c9
AS
1903
1904 return lookup_pointer_type (elt_type);
1905 }
1906}
1907
1908/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
1909 Otherwise, returns either a standard GDB array with bounds set
1910 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1911 GDB array. Returns NULL if ARR is a null fat pointer. */
1912
d2e4a39e
AS
1913struct value *
1914ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 1915{
df407dfe 1916 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 1917 {
d2e4a39e 1918 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 1919
14f9c5c9 1920 if (arrType == NULL)
4c4b4cd2 1921 return NULL;
14f9c5c9
AS
1922 return value_cast (arrType, value_copy (desc_data (arr)));
1923 }
ad82864c
JB
1924 else if (ada_is_constrained_packed_array_type (value_type (arr)))
1925 return decode_constrained_packed_array (arr);
14f9c5c9
AS
1926 else
1927 return arr;
1928}
1929
1930/* If ARR does not represent an array, returns ARR unchanged.
1931 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
1932 be ARR itself if it already is in the proper form). */
1933
720d1a40 1934struct value *
d2e4a39e 1935ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 1936{
df407dfe 1937 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 1938 {
d2e4a39e 1939 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 1940
14f9c5c9 1941 if (arrVal == NULL)
323e0a4a 1942 error (_("Bounds unavailable for null array pointer."));
529cad9c 1943 check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
1944 return value_ind (arrVal);
1945 }
ad82864c
JB
1946 else if (ada_is_constrained_packed_array_type (value_type (arr)))
1947 return decode_constrained_packed_array (arr);
d2e4a39e 1948 else
14f9c5c9
AS
1949 return arr;
1950}
1951
1952/* If TYPE represents a GNAT array type, return it translated to an
1953 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
1954 packing). For other types, is the identity. */
1955
d2e4a39e
AS
1956struct type *
1957ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 1958{
ad82864c
JB
1959 if (ada_is_constrained_packed_array_type (type))
1960 return decode_constrained_packed_array_type (type);
17280b9f
UW
1961
1962 if (ada_is_array_descriptor_type (type))
556bdfd4 1963 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
1964
1965 return type;
14f9c5c9
AS
1966}
1967
4c4b4cd2
PH
1968/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1969
ad82864c
JB
1970static int
1971ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
1972{
1973 if (type == NULL)
1974 return 0;
4c4b4cd2 1975 type = desc_base_type (type);
61ee279c 1976 type = ada_check_typedef (type);
d2e4a39e 1977 return
14f9c5c9
AS
1978 ada_type_name (type) != NULL
1979 && strstr (ada_type_name (type), "___XP") != NULL;
1980}
1981
ad82864c
JB
1982/* Non-zero iff TYPE represents a standard GNAT constrained
1983 packed-array type. */
1984
1985int
1986ada_is_constrained_packed_array_type (struct type *type)
1987{
1988 return ada_is_packed_array_type (type)
1989 && !ada_is_array_descriptor_type (type);
1990}
1991
1992/* Non-zero iff TYPE represents an array descriptor for a
1993 unconstrained packed-array type. */
1994
1995static int
1996ada_is_unconstrained_packed_array_type (struct type *type)
1997{
1998 return ada_is_packed_array_type (type)
1999 && ada_is_array_descriptor_type (type);
2000}
2001
2002/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2003 return the size of its elements in bits. */
2004
2005static long
2006decode_packed_array_bitsize (struct type *type)
2007{
0d5cff50
DE
2008 const char *raw_name;
2009 const char *tail;
ad82864c
JB
2010 long bits;
2011
720d1a40
JB
2012 /* Access to arrays implemented as fat pointers are encoded as a typedef
2013 of the fat pointer type. We need the name of the fat pointer type
2014 to do the decoding, so strip the typedef layer. */
2015 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2016 type = ada_typedef_target_type (type);
2017
2018 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2019 if (!raw_name)
2020 raw_name = ada_type_name (desc_base_type (type));
2021
2022 if (!raw_name)
2023 return 0;
2024
2025 tail = strstr (raw_name, "___XP");
720d1a40 2026 gdb_assert (tail != NULL);
ad82864c
JB
2027
2028 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2029 {
2030 lim_warning
2031 (_("could not understand bit size information on packed array"));
2032 return 0;
2033 }
2034
2035 return bits;
2036}
2037
14f9c5c9
AS
2038/* Given that TYPE is a standard GDB array type with all bounds filled
2039 in, and that the element size of its ultimate scalar constituents
2040 (that is, either its elements, or, if it is an array of arrays, its
2041 elements' elements, etc.) is *ELT_BITS, return an identical type,
2042 but with the bit sizes of its elements (and those of any
2043 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2
PH
2044 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2045 in bits. */
2046
d2e4a39e 2047static struct type *
ad82864c 2048constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2049{
d2e4a39e
AS
2050 struct type *new_elt_type;
2051 struct type *new_type;
99b1c762
JB
2052 struct type *index_type_desc;
2053 struct type *index_type;
14f9c5c9
AS
2054 LONGEST low_bound, high_bound;
2055
61ee279c 2056 type = ada_check_typedef (type);
14f9c5c9
AS
2057 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2058 return type;
2059
99b1c762
JB
2060 index_type_desc = ada_find_parallel_type (type, "___XA");
2061 if (index_type_desc)
2062 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2063 NULL);
2064 else
2065 index_type = TYPE_INDEX_TYPE (type);
2066
e9bb382b 2067 new_type = alloc_type_copy (type);
ad82864c
JB
2068 new_elt_type =
2069 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2070 elt_bits);
99b1c762 2071 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2072 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2073 TYPE_NAME (new_type) = ada_type_name (type);
2074
99b1c762 2075 if (get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2076 low_bound = high_bound = 0;
2077 if (high_bound < low_bound)
2078 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2079 else
14f9c5c9
AS
2080 {
2081 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2082 TYPE_LENGTH (new_type) =
4c4b4cd2 2083 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2084 }
2085
876cecd0 2086 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2087 return new_type;
2088}
2089
ad82864c
JB
2090/* The array type encoded by TYPE, where
2091 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2092
d2e4a39e 2093static struct type *
ad82864c 2094decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2095{
0d5cff50 2096 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2097 char *name;
0d5cff50 2098 const char *tail;
d2e4a39e 2099 struct type *shadow_type;
14f9c5c9 2100 long bits;
14f9c5c9 2101
727e3d2e
JB
2102 if (!raw_name)
2103 raw_name = ada_type_name (desc_base_type (type));
2104
2105 if (!raw_name)
2106 return NULL;
2107
2108 name = (char *) alloca (strlen (raw_name) + 1);
2109 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2110 type = desc_base_type (type);
2111
14f9c5c9
AS
2112 memcpy (name, raw_name, tail - raw_name);
2113 name[tail - raw_name] = '\000';
2114
b4ba55a1
JB
2115 shadow_type = ada_find_parallel_type_with_name (type, name);
2116
2117 if (shadow_type == NULL)
14f9c5c9 2118 {
323e0a4a 2119 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2120 return NULL;
2121 }
cb249c71 2122 CHECK_TYPEDEF (shadow_type);
14f9c5c9
AS
2123
2124 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2125 {
0963b4bd
MS
2126 lim_warning (_("could not understand bounds "
2127 "information on packed array"));
14f9c5c9
AS
2128 return NULL;
2129 }
d2e4a39e 2130
ad82864c
JB
2131 bits = decode_packed_array_bitsize (type);
2132 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2133}
2134
ad82864c
JB
2135/* Given that ARR is a struct value *indicating a GNAT constrained packed
2136 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2137 standard GDB array type except that the BITSIZEs of the array
2138 target types are set to the number of bits in each element, and the
4c4b4cd2 2139 type length is set appropriately. */
14f9c5c9 2140
d2e4a39e 2141static struct value *
ad82864c 2142decode_constrained_packed_array (struct value *arr)
14f9c5c9 2143{
4c4b4cd2 2144 struct type *type;
14f9c5c9 2145
4c4b4cd2 2146 arr = ada_coerce_ref (arr);
284614f0
JB
2147
2148 /* If our value is a pointer, then dererence it. Make sure that
2149 this operation does not cause the target type to be fixed, as
2150 this would indirectly cause this array to be decoded. The rest
2151 of the routine assumes that the array hasn't been decoded yet,
2152 so we use the basic "value_ind" routine to perform the dereferencing,
2153 as opposed to using "ada_value_ind". */
828292f2 2154 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2155 arr = value_ind (arr);
4c4b4cd2 2156
ad82864c 2157 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2158 if (type == NULL)
2159 {
323e0a4a 2160 error (_("can't unpack array"));
14f9c5c9
AS
2161 return NULL;
2162 }
61ee279c 2163
50810684 2164 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2165 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2166 {
2167 /* This is a (right-justified) modular type representing a packed
2168 array with no wrapper. In order to interpret the value through
2169 the (left-justified) packed array type we just built, we must
2170 first left-justify it. */
2171 int bit_size, bit_pos;
2172 ULONGEST mod;
2173
df407dfe 2174 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2175 bit_size = 0;
2176 while (mod > 0)
2177 {
2178 bit_size += 1;
2179 mod >>= 1;
2180 }
df407dfe 2181 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2182 arr = ada_value_primitive_packed_val (arr, NULL,
2183 bit_pos / HOST_CHAR_BIT,
2184 bit_pos % HOST_CHAR_BIT,
2185 bit_size,
2186 type);
2187 }
2188
4c4b4cd2 2189 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2190}
2191
2192
2193/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2194 given in IND. ARR must be a simple array. */
14f9c5c9 2195
d2e4a39e
AS
2196static struct value *
2197value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2198{
2199 int i;
2200 int bits, elt_off, bit_off;
2201 long elt_total_bit_offset;
d2e4a39e
AS
2202 struct type *elt_type;
2203 struct value *v;
14f9c5c9
AS
2204
2205 bits = 0;
2206 elt_total_bit_offset = 0;
df407dfe 2207 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2208 for (i = 0; i < arity; i += 1)
14f9c5c9 2209 {
d2e4a39e 2210 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2211 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2212 error
0963b4bd
MS
2213 (_("attempt to do packed indexing of "
2214 "something other than a packed array"));
14f9c5c9 2215 else
4c4b4cd2
PH
2216 {
2217 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2218 LONGEST lowerbound, upperbound;
2219 LONGEST idx;
2220
2221 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2222 {
323e0a4a 2223 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2224 lowerbound = upperbound = 0;
2225 }
2226
3cb382c9 2227 idx = pos_atr (ind[i]);
4c4b4cd2 2228 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2229 lim_warning (_("packed array index %ld out of bounds"),
2230 (long) idx);
4c4b4cd2
PH
2231 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2232 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2233 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2234 }
14f9c5c9
AS
2235 }
2236 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2237 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2238
2239 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2240 bits, elt_type);
14f9c5c9
AS
2241 return v;
2242}
2243
4c4b4cd2 2244/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2245
2246static int
d2e4a39e 2247has_negatives (struct type *type)
14f9c5c9 2248{
d2e4a39e
AS
2249 switch (TYPE_CODE (type))
2250 {
2251 default:
2252 return 0;
2253 case TYPE_CODE_INT:
2254 return !TYPE_UNSIGNED (type);
2255 case TYPE_CODE_RANGE:
2256 return TYPE_LOW_BOUND (type) < 0;
2257 }
14f9c5c9 2258}
d2e4a39e 2259
14f9c5c9
AS
2260
2261/* Create a new value of type TYPE from the contents of OBJ starting
2262 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2263 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
0963b4bd 2264 assigning through the result will set the field fetched from.
4c4b4cd2
PH
2265 VALADDR is ignored unless OBJ is NULL, in which case,
2266 VALADDR+OFFSET must address the start of storage containing the
2267 packed value. The value returned in this case is never an lval.
2268 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
14f9c5c9 2269
d2e4a39e 2270struct value *
fc1a4b47 2271ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
a2bd3dcd 2272 long offset, int bit_offset, int bit_size,
4c4b4cd2 2273 struct type *type)
14f9c5c9 2274{
d2e4a39e 2275 struct value *v;
4c4b4cd2
PH
2276 int src, /* Index into the source area */
2277 targ, /* Index into the target area */
2278 srcBitsLeft, /* Number of source bits left to move */
2279 nsrc, ntarg, /* Number of source and target bytes */
2280 unusedLS, /* Number of bits in next significant
2281 byte of source that are unused */
2282 accumSize; /* Number of meaningful bits in accum */
2283 unsigned char *bytes; /* First byte containing data to unpack */
d2e4a39e 2284 unsigned char *unpacked;
4c4b4cd2 2285 unsigned long accum; /* Staging area for bits being transferred */
14f9c5c9
AS
2286 unsigned char sign;
2287 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
4c4b4cd2
PH
2288 /* Transmit bytes from least to most significant; delta is the direction
2289 the indices move. */
50810684 2290 int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1;
14f9c5c9 2291
61ee279c 2292 type = ada_check_typedef (type);
14f9c5c9
AS
2293
2294 if (obj == NULL)
2295 {
2296 v = allocate_value (type);
d2e4a39e 2297 bytes = (unsigned char *) (valaddr + offset);
14f9c5c9 2298 }
9214ee5f 2299 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
14f9c5c9 2300 {
53ba8333 2301 v = value_at (type, value_address (obj));
d2e4a39e 2302 bytes = (unsigned char *) alloca (len);
53ba8333 2303 read_memory (value_address (v) + offset, bytes, len);
14f9c5c9 2304 }
d2e4a39e 2305 else
14f9c5c9
AS
2306 {
2307 v = allocate_value (type);
0fd88904 2308 bytes = (unsigned char *) value_contents (obj) + offset;
14f9c5c9 2309 }
d2e4a39e
AS
2310
2311 if (obj != NULL)
14f9c5c9 2312 {
53ba8333 2313 long new_offset = offset;
5b4ee69b 2314
74bcbdf3 2315 set_value_component_location (v, obj);
9bbda503
AC
2316 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2317 set_value_bitsize (v, bit_size);
df407dfe 2318 if (value_bitpos (v) >= HOST_CHAR_BIT)
4c4b4cd2 2319 {
53ba8333 2320 ++new_offset;
9bbda503 2321 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
4c4b4cd2 2322 }
53ba8333
JB
2323 set_value_offset (v, new_offset);
2324
2325 /* Also set the parent value. This is needed when trying to
2326 assign a new value (in inferior memory). */
2327 set_value_parent (v, obj);
14f9c5c9
AS
2328 }
2329 else
9bbda503 2330 set_value_bitsize (v, bit_size);
0fd88904 2331 unpacked = (unsigned char *) value_contents (v);
14f9c5c9
AS
2332
2333 srcBitsLeft = bit_size;
2334 nsrc = len;
2335 ntarg = TYPE_LENGTH (type);
2336 sign = 0;
2337 if (bit_size == 0)
2338 {
2339 memset (unpacked, 0, TYPE_LENGTH (type));
2340 return v;
2341 }
50810684 2342 else if (gdbarch_bits_big_endian (get_type_arch (type)))
14f9c5c9 2343 {
d2e4a39e 2344 src = len - 1;
1265e4aa
JB
2345 if (has_negatives (type)
2346 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2347 sign = ~0;
d2e4a39e
AS
2348
2349 unusedLS =
4c4b4cd2
PH
2350 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2351 % HOST_CHAR_BIT;
14f9c5c9
AS
2352
2353 switch (TYPE_CODE (type))
4c4b4cd2
PH
2354 {
2355 case TYPE_CODE_ARRAY:
2356 case TYPE_CODE_UNION:
2357 case TYPE_CODE_STRUCT:
2358 /* Non-scalar values must be aligned at a byte boundary... */
2359 accumSize =
2360 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2361 /* ... And are placed at the beginning (most-significant) bytes
2362 of the target. */
529cad9c 2363 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
0056e4d5 2364 ntarg = targ + 1;
4c4b4cd2
PH
2365 break;
2366 default:
2367 accumSize = 0;
2368 targ = TYPE_LENGTH (type) - 1;
2369 break;
2370 }
14f9c5c9 2371 }
d2e4a39e 2372 else
14f9c5c9
AS
2373 {
2374 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2375
2376 src = targ = 0;
2377 unusedLS = bit_offset;
2378 accumSize = 0;
2379
d2e4a39e 2380 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2381 sign = ~0;
14f9c5c9 2382 }
d2e4a39e 2383
14f9c5c9
AS
2384 accum = 0;
2385 while (nsrc > 0)
2386 {
2387 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2388 part of the value. */
d2e4a39e 2389 unsigned int unusedMSMask =
4c4b4cd2
PH
2390 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2391 1;
2392 /* Sign-extend bits for this byte. */
14f9c5c9 2393 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2394
d2e4a39e 2395 accum |=
4c4b4cd2 2396 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2397 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2398 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2
PH
2399 {
2400 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2401 accumSize -= HOST_CHAR_BIT;
2402 accum >>= HOST_CHAR_BIT;
2403 ntarg -= 1;
2404 targ += delta;
2405 }
14f9c5c9
AS
2406 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2407 unusedLS = 0;
2408 nsrc -= 1;
2409 src += delta;
2410 }
2411 while (ntarg > 0)
2412 {
2413 accum |= sign << accumSize;
2414 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2415 accumSize -= HOST_CHAR_BIT;
2416 accum >>= HOST_CHAR_BIT;
2417 ntarg -= 1;
2418 targ += delta;
2419 }
2420
2421 return v;
2422}
d2e4a39e 2423
14f9c5c9
AS
2424/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2425 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2426 not overlap. */
14f9c5c9 2427static void
fc1a4b47 2428move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2429 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2430{
2431 unsigned int accum, mask;
2432 int accum_bits, chunk_size;
2433
2434 target += targ_offset / HOST_CHAR_BIT;
2435 targ_offset %= HOST_CHAR_BIT;
2436 source += src_offset / HOST_CHAR_BIT;
2437 src_offset %= HOST_CHAR_BIT;
50810684 2438 if (bits_big_endian_p)
14f9c5c9
AS
2439 {
2440 accum = (unsigned char) *source;
2441 source += 1;
2442 accum_bits = HOST_CHAR_BIT - src_offset;
2443
d2e4a39e 2444 while (n > 0)
4c4b4cd2
PH
2445 {
2446 int unused_right;
5b4ee69b 2447
4c4b4cd2
PH
2448 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2449 accum_bits += HOST_CHAR_BIT;
2450 source += 1;
2451 chunk_size = HOST_CHAR_BIT - targ_offset;
2452 if (chunk_size > n)
2453 chunk_size = n;
2454 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2455 mask = ((1 << chunk_size) - 1) << unused_right;
2456 *target =
2457 (*target & ~mask)
2458 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2459 n -= chunk_size;
2460 accum_bits -= chunk_size;
2461 target += 1;
2462 targ_offset = 0;
2463 }
14f9c5c9
AS
2464 }
2465 else
2466 {
2467 accum = (unsigned char) *source >> src_offset;
2468 source += 1;
2469 accum_bits = HOST_CHAR_BIT - src_offset;
2470
d2e4a39e 2471 while (n > 0)
4c4b4cd2
PH
2472 {
2473 accum = accum + ((unsigned char) *source << accum_bits);
2474 accum_bits += HOST_CHAR_BIT;
2475 source += 1;
2476 chunk_size = HOST_CHAR_BIT - targ_offset;
2477 if (chunk_size > n)
2478 chunk_size = n;
2479 mask = ((1 << chunk_size) - 1) << targ_offset;
2480 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2481 n -= chunk_size;
2482 accum_bits -= chunk_size;
2483 accum >>= chunk_size;
2484 target += 1;
2485 targ_offset = 0;
2486 }
14f9c5c9
AS
2487 }
2488}
2489
14f9c5c9
AS
2490/* Store the contents of FROMVAL into the location of TOVAL.
2491 Return a new value with the location of TOVAL and contents of
2492 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2493 floating-point or non-scalar types. */
14f9c5c9 2494
d2e4a39e
AS
2495static struct value *
2496ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2497{
df407dfe
AC
2498 struct type *type = value_type (toval);
2499 int bits = value_bitsize (toval);
14f9c5c9 2500
52ce6436
PH
2501 toval = ada_coerce_ref (toval);
2502 fromval = ada_coerce_ref (fromval);
2503
2504 if (ada_is_direct_array_type (value_type (toval)))
2505 toval = ada_coerce_to_simple_array (toval);
2506 if (ada_is_direct_array_type (value_type (fromval)))
2507 fromval = ada_coerce_to_simple_array (fromval);
2508
88e3b34b 2509 if (!deprecated_value_modifiable (toval))
323e0a4a 2510 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2511
d2e4a39e 2512 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2513 && bits > 0
d2e4a39e 2514 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2515 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2516 {
df407dfe
AC
2517 int len = (value_bitpos (toval)
2518 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2519 int from_size;
948f8e3d 2520 gdb_byte *buffer = alloca (len);
d2e4a39e 2521 struct value *val;
42ae5230 2522 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2523
2524 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2525 fromval = value_cast (type, fromval);
14f9c5c9 2526
52ce6436 2527 read_memory (to_addr, buffer, len);
aced2898
PH
2528 from_size = value_bitsize (fromval);
2529 if (from_size == 0)
2530 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2531 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2532 move_bits (buffer, value_bitpos (toval),
50810684 2533 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2534 else
50810684
UW
2535 move_bits (buffer, value_bitpos (toval),
2536 value_contents (fromval), 0, bits, 0);
972daa01 2537 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2538
14f9c5c9 2539 val = value_copy (toval);
0fd88904 2540 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2541 TYPE_LENGTH (type));
04624583 2542 deprecated_set_value_type (val, type);
d2e4a39e 2543
14f9c5c9
AS
2544 return val;
2545 }
2546
2547 return value_assign (toval, fromval);
2548}
2549
2550
52ce6436
PH
2551/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2552 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2553 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2554 * COMPONENT, and not the inferior's memory. The current contents
2555 * of COMPONENT are ignored. */
2556static void
2557value_assign_to_component (struct value *container, struct value *component,
2558 struct value *val)
2559{
2560 LONGEST offset_in_container =
42ae5230 2561 (LONGEST) (value_address (component) - value_address (container));
52ce6436
PH
2562 int bit_offset_in_container =
2563 value_bitpos (component) - value_bitpos (container);
2564 int bits;
2565
2566 val = value_cast (value_type (component), val);
2567
2568 if (value_bitsize (component) == 0)
2569 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2570 else
2571 bits = value_bitsize (component);
2572
50810684 2573 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
52ce6436
PH
2574 move_bits (value_contents_writeable (container) + offset_in_container,
2575 value_bitpos (container) + bit_offset_in_container,
2576 value_contents (val),
2577 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
50810684 2578 bits, 1);
52ce6436
PH
2579 else
2580 move_bits (value_contents_writeable (container) + offset_in_container,
2581 value_bitpos (container) + bit_offset_in_container,
50810684 2582 value_contents (val), 0, bits, 0);
52ce6436
PH
2583}
2584
4c4b4cd2
PH
2585/* The value of the element of array ARR at the ARITY indices given in IND.
2586 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2587 thereto. */
2588
d2e4a39e
AS
2589struct value *
2590ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2591{
2592 int k;
d2e4a39e
AS
2593 struct value *elt;
2594 struct type *elt_type;
14f9c5c9
AS
2595
2596 elt = ada_coerce_to_simple_array (arr);
2597
df407dfe 2598 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2599 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2600 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2601 return value_subscript_packed (elt, arity, ind);
2602
2603 for (k = 0; k < arity; k += 1)
2604 {
2605 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2606 error (_("too many subscripts (%d expected)"), k);
2497b498 2607 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2608 }
2609 return elt;
2610}
2611
2612/* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2613 value of the element of *ARR at the ARITY indices given in
4c4b4cd2 2614 IND. Does not read the entire array into memory. */
14f9c5c9 2615
2c0b251b 2616static struct value *
d2e4a39e 2617ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
4c4b4cd2 2618 struct value **ind)
14f9c5c9
AS
2619{
2620 int k;
2621
2622 for (k = 0; k < arity; k += 1)
2623 {
2624 LONGEST lwb, upb;
14f9c5c9
AS
2625
2626 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2627 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2628 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2629 value_copy (arr));
14f9c5c9 2630 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2497b498 2631 arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
14f9c5c9
AS
2632 type = TYPE_TARGET_TYPE (type);
2633 }
2634
2635 return value_ind (arr);
2636}
2637
0b5d8877 2638/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
f5938064
JG
2639 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2640 elements starting at index LOW. The lower bound of this array is LOW, as
0963b4bd 2641 per Ada rules. */
0b5d8877 2642static struct value *
f5938064
JG
2643ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2644 int low, int high)
0b5d8877 2645{
b0dd7688 2646 struct type *type0 = ada_check_typedef (type);
6c038f32 2647 CORE_ADDR base = value_as_address (array_ptr)
b0dd7688
JB
2648 + ((low - ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0)))
2649 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
6c038f32 2650 struct type *index_type =
b0dd7688 2651 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)),
0b5d8877 2652 low, high);
6c038f32 2653 struct type *slice_type =
b0dd7688 2654 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
5b4ee69b 2655
f5938064 2656 return value_at_lazy (slice_type, base);
0b5d8877
PH
2657}
2658
2659
2660static struct value *
2661ada_value_slice (struct value *array, int low, int high)
2662{
b0dd7688 2663 struct type *type = ada_check_typedef (value_type (array));
6c038f32 2664 struct type *index_type =
0b5d8877 2665 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
6c038f32 2666 struct type *slice_type =
0b5d8877 2667 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
5b4ee69b 2668
6c038f32 2669 return value_cast (slice_type, value_slice (array, low, high - low + 1));
0b5d8877
PH
2670}
2671
14f9c5c9
AS
2672/* If type is a record type in the form of a standard GNAT array
2673 descriptor, returns the number of dimensions for type. If arr is a
2674 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2675 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2676
2677int
d2e4a39e 2678ada_array_arity (struct type *type)
14f9c5c9
AS
2679{
2680 int arity;
2681
2682 if (type == NULL)
2683 return 0;
2684
2685 type = desc_base_type (type);
2686
2687 arity = 0;
d2e4a39e 2688 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2689 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2690 else
2691 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2692 {
4c4b4cd2 2693 arity += 1;
61ee279c 2694 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2695 }
d2e4a39e 2696
14f9c5c9
AS
2697 return arity;
2698}
2699
2700/* If TYPE is a record type in the form of a standard GNAT array
2701 descriptor or a simple array type, returns the element type for
2702 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2703 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2704
d2e4a39e
AS
2705struct type *
2706ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2707{
2708 type = desc_base_type (type);
2709
d2e4a39e 2710 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2711 {
2712 int k;
d2e4a39e 2713 struct type *p_array_type;
14f9c5c9 2714
556bdfd4 2715 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
2716
2717 k = ada_array_arity (type);
2718 if (k == 0)
4c4b4cd2 2719 return NULL;
d2e4a39e 2720
4c4b4cd2 2721 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2722 if (nindices >= 0 && k > nindices)
4c4b4cd2 2723 k = nindices;
d2e4a39e 2724 while (k > 0 && p_array_type != NULL)
4c4b4cd2 2725 {
61ee279c 2726 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
2727 k -= 1;
2728 }
14f9c5c9
AS
2729 return p_array_type;
2730 }
2731 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2732 {
2733 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
2734 {
2735 type = TYPE_TARGET_TYPE (type);
2736 nindices -= 1;
2737 }
14f9c5c9
AS
2738 return type;
2739 }
2740
2741 return NULL;
2742}
2743
4c4b4cd2 2744/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
2745 Does not examine memory. Throws an error if N is invalid or TYPE
2746 is not an array type. NAME is the name of the Ada attribute being
2747 evaluated ('range, 'first, 'last, or 'length); it is used in building
2748 the error message. */
14f9c5c9 2749
1eea4ebd
UW
2750static struct type *
2751ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 2752{
4c4b4cd2
PH
2753 struct type *result_type;
2754
14f9c5c9
AS
2755 type = desc_base_type (type);
2756
1eea4ebd
UW
2757 if (n < 0 || n > ada_array_arity (type))
2758 error (_("invalid dimension number to '%s"), name);
14f9c5c9 2759
4c4b4cd2 2760 if (ada_is_simple_array_type (type))
14f9c5c9
AS
2761 {
2762 int i;
2763
2764 for (i = 1; i < n; i += 1)
4c4b4cd2 2765 type = TYPE_TARGET_TYPE (type);
262452ec 2766 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
2767 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2768 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 2769 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
2770 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2771 result_type = NULL;
14f9c5c9 2772 }
d2e4a39e 2773 else
1eea4ebd
UW
2774 {
2775 result_type = desc_index_type (desc_bounds_type (type), n);
2776 if (result_type == NULL)
2777 error (_("attempt to take bound of something that is not an array"));
2778 }
2779
2780 return result_type;
14f9c5c9
AS
2781}
2782
2783/* Given that arr is an array type, returns the lower bound of the
2784 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 2785 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
2786 array-descriptor type. It works for other arrays with bounds supplied
2787 by run-time quantities other than discriminants. */
14f9c5c9 2788
abb68b3e 2789static LONGEST
1eea4ebd 2790ada_array_bound_from_type (struct type * arr_type, int n, int which)
14f9c5c9 2791{
1ce677a4 2792 struct type *type, *elt_type, *index_type_desc, *index_type;
1ce677a4 2793 int i;
262452ec
JK
2794
2795 gdb_assert (which == 0 || which == 1);
14f9c5c9 2796
ad82864c
JB
2797 if (ada_is_constrained_packed_array_type (arr_type))
2798 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 2799
4c4b4cd2 2800 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 2801 return (LONGEST) - which;
14f9c5c9
AS
2802
2803 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2804 type = TYPE_TARGET_TYPE (arr_type);
2805 else
2806 type = arr_type;
2807
1ce677a4
UW
2808 elt_type = type;
2809 for (i = n; i > 1; i--)
2810 elt_type = TYPE_TARGET_TYPE (type);
2811
14f9c5c9 2812 index_type_desc = ada_find_parallel_type (type, "___XA");
28c85d6c 2813 ada_fixup_array_indexes_type (index_type_desc);
262452ec 2814 if (index_type_desc != NULL)
28c85d6c
JB
2815 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
2816 NULL);
262452ec 2817 else
1ce677a4 2818 index_type = TYPE_INDEX_TYPE (elt_type);
262452ec 2819
43bbcdc2
PH
2820 return
2821 (LONGEST) (which == 0
2822 ? ada_discrete_type_low_bound (index_type)
2823 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
2824}
2825
2826/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
2827 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2828 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 2829 supplied by run-time quantities other than discriminants. */
14f9c5c9 2830
1eea4ebd 2831static LONGEST
4dc81987 2832ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 2833{
df407dfe 2834 struct type *arr_type = value_type (arr);
14f9c5c9 2835
ad82864c
JB
2836 if (ada_is_constrained_packed_array_type (arr_type))
2837 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 2838 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 2839 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 2840 else
1eea4ebd 2841 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
2842}
2843
2844/* Given that arr is an array value, returns the length of the
2845 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
2846 supplied by run-time quantities other than discriminants.
2847 Does not work for arrays indexed by enumeration types with representation
2848 clauses at the moment. */
14f9c5c9 2849
1eea4ebd 2850static LONGEST
d2e4a39e 2851ada_array_length (struct value *arr, int n)
14f9c5c9 2852{
df407dfe 2853 struct type *arr_type = ada_check_typedef (value_type (arr));
14f9c5c9 2854
ad82864c
JB
2855 if (ada_is_constrained_packed_array_type (arr_type))
2856 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 2857
4c4b4cd2 2858 if (ada_is_simple_array_type (arr_type))
1eea4ebd
UW
2859 return (ada_array_bound_from_type (arr_type, n, 1)
2860 - ada_array_bound_from_type (arr_type, n, 0) + 1);
14f9c5c9 2861 else
1eea4ebd
UW
2862 return (value_as_long (desc_one_bound (desc_bounds (arr), n, 1))
2863 - value_as_long (desc_one_bound (desc_bounds (arr), n, 0)) + 1);
4c4b4cd2
PH
2864}
2865
2866/* An empty array whose type is that of ARR_TYPE (an array type),
2867 with bounds LOW to LOW-1. */
2868
2869static struct value *
2870empty_array (struct type *arr_type, int low)
2871{
b0dd7688 2872 struct type *arr_type0 = ada_check_typedef (arr_type);
6c038f32 2873 struct type *index_type =
b0dd7688 2874 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)),
0b5d8877 2875 low, low - 1);
b0dd7688 2876 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 2877
0b5d8877 2878 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 2879}
14f9c5c9 2880\f
d2e4a39e 2881
4c4b4cd2 2882 /* Name resolution */
14f9c5c9 2883
4c4b4cd2
PH
2884/* The "decoded" name for the user-definable Ada operator corresponding
2885 to OP. */
14f9c5c9 2886
d2e4a39e 2887static const char *
4c4b4cd2 2888ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
2889{
2890 int i;
2891
4c4b4cd2 2892 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
2893 {
2894 if (ada_opname_table[i].op == op)
4c4b4cd2 2895 return ada_opname_table[i].decoded;
14f9c5c9 2896 }
323e0a4a 2897 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
2898}
2899
2900
4c4b4cd2
PH
2901/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2902 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2903 undefined namespace) and converts operators that are
2904 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
2905 non-null, it provides a preferred result type [at the moment, only
2906 type void has any effect---causing procedures to be preferred over
2907 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 2908 return type is preferred. May change (expand) *EXP. */
14f9c5c9 2909
4c4b4cd2
PH
2910static void
2911resolve (struct expression **expp, int void_context_p)
14f9c5c9 2912{
30b15541
UW
2913 struct type *context_type = NULL;
2914 int pc = 0;
2915
2916 if (void_context_p)
2917 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
2918
2919 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
2920}
2921
4c4b4cd2
PH
2922/* Resolve the operator of the subexpression beginning at
2923 position *POS of *EXPP. "Resolving" consists of replacing
2924 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2925 with their resolutions, replacing built-in operators with
2926 function calls to user-defined operators, where appropriate, and,
2927 when DEPROCEDURE_P is non-zero, converting function-valued variables
2928 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2929 are as in ada_resolve, above. */
14f9c5c9 2930
d2e4a39e 2931static struct value *
4c4b4cd2 2932resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
76a01679 2933 struct type *context_type)
14f9c5c9
AS
2934{
2935 int pc = *pos;
2936 int i;
4c4b4cd2 2937 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 2938 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
2939 struct value **argvec; /* Vector of operand types (alloca'ed). */
2940 int nargs; /* Number of operands. */
52ce6436 2941 int oplen;
14f9c5c9
AS
2942
2943 argvec = NULL;
2944 nargs = 0;
2945 exp = *expp;
2946
52ce6436
PH
2947 /* Pass one: resolve operands, saving their types and updating *pos,
2948 if needed. */
14f9c5c9
AS
2949 switch (op)
2950 {
4c4b4cd2
PH
2951 case OP_FUNCALL:
2952 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
2953 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2954 *pos += 7;
4c4b4cd2
PH
2955 else
2956 {
2957 *pos += 3;
2958 resolve_subexp (expp, pos, 0, NULL);
2959 }
2960 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
2961 break;
2962
14f9c5c9 2963 case UNOP_ADDR:
4c4b4cd2
PH
2964 *pos += 1;
2965 resolve_subexp (expp, pos, 0, NULL);
2966 break;
2967
52ce6436
PH
2968 case UNOP_QUAL:
2969 *pos += 3;
17466c1a 2970 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
2971 break;
2972
52ce6436 2973 case OP_ATR_MODULUS:
4c4b4cd2
PH
2974 case OP_ATR_SIZE:
2975 case OP_ATR_TAG:
4c4b4cd2
PH
2976 case OP_ATR_FIRST:
2977 case OP_ATR_LAST:
2978 case OP_ATR_LENGTH:
2979 case OP_ATR_POS:
2980 case OP_ATR_VAL:
4c4b4cd2
PH
2981 case OP_ATR_MIN:
2982 case OP_ATR_MAX:
52ce6436
PH
2983 case TERNOP_IN_RANGE:
2984 case BINOP_IN_BOUNDS:
2985 case UNOP_IN_RANGE:
2986 case OP_AGGREGATE:
2987 case OP_OTHERS:
2988 case OP_CHOICES:
2989 case OP_POSITIONAL:
2990 case OP_DISCRETE_RANGE:
2991 case OP_NAME:
2992 ada_forward_operator_length (exp, pc, &oplen, &nargs);
2993 *pos += oplen;
14f9c5c9
AS
2994 break;
2995
2996 case BINOP_ASSIGN:
2997 {
4c4b4cd2
PH
2998 struct value *arg1;
2999
3000 *pos += 1;
3001 arg1 = resolve_subexp (expp, pos, 0, NULL);
3002 if (arg1 == NULL)
3003 resolve_subexp (expp, pos, 1, NULL);
3004 else
df407dfe 3005 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 3006 break;
14f9c5c9
AS
3007 }
3008
4c4b4cd2 3009 case UNOP_CAST:
4c4b4cd2
PH
3010 *pos += 3;
3011 nargs = 1;
3012 break;
14f9c5c9 3013
4c4b4cd2
PH
3014 case BINOP_ADD:
3015 case BINOP_SUB:
3016 case BINOP_MUL:
3017 case BINOP_DIV:
3018 case BINOP_REM:
3019 case BINOP_MOD:
3020 case BINOP_EXP:
3021 case BINOP_CONCAT:
3022 case BINOP_LOGICAL_AND:
3023 case BINOP_LOGICAL_OR:
3024 case BINOP_BITWISE_AND:
3025 case BINOP_BITWISE_IOR:
3026 case BINOP_BITWISE_XOR:
14f9c5c9 3027
4c4b4cd2
PH
3028 case BINOP_EQUAL:
3029 case BINOP_NOTEQUAL:
3030 case BINOP_LESS:
3031 case BINOP_GTR:
3032 case BINOP_LEQ:
3033 case BINOP_GEQ:
14f9c5c9 3034
4c4b4cd2
PH
3035 case BINOP_REPEAT:
3036 case BINOP_SUBSCRIPT:
3037 case BINOP_COMMA:
40c8aaa9
JB
3038 *pos += 1;
3039 nargs = 2;
3040 break;
14f9c5c9 3041
4c4b4cd2
PH
3042 case UNOP_NEG:
3043 case UNOP_PLUS:
3044 case UNOP_LOGICAL_NOT:
3045 case UNOP_ABS:
3046 case UNOP_IND:
3047 *pos += 1;
3048 nargs = 1;
3049 break;
14f9c5c9 3050
4c4b4cd2
PH
3051 case OP_LONG:
3052 case OP_DOUBLE:
3053 case OP_VAR_VALUE:
3054 *pos += 4;
3055 break;
14f9c5c9 3056
4c4b4cd2
PH
3057 case OP_TYPE:
3058 case OP_BOOL:
3059 case OP_LAST:
4c4b4cd2
PH
3060 case OP_INTERNALVAR:
3061 *pos += 3;
3062 break;
14f9c5c9 3063
4c4b4cd2
PH
3064 case UNOP_MEMVAL:
3065 *pos += 3;
3066 nargs = 1;
3067 break;
3068
67f3407f
DJ
3069 case OP_REGISTER:
3070 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3071 break;
3072
4c4b4cd2
PH
3073 case STRUCTOP_STRUCT:
3074 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3075 nargs = 1;
3076 break;
3077
4c4b4cd2 3078 case TERNOP_SLICE:
4c4b4cd2
PH
3079 *pos += 1;
3080 nargs = 3;
3081 break;
3082
52ce6436 3083 case OP_STRING:
14f9c5c9 3084 break;
4c4b4cd2
PH
3085
3086 default:
323e0a4a 3087 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3088 }
3089
76a01679 3090 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
4c4b4cd2
PH
3091 for (i = 0; i < nargs; i += 1)
3092 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3093 argvec[i] = NULL;
3094 exp = *expp;
3095
3096 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3097 switch (op)
3098 {
3099 default:
3100 break;
3101
14f9c5c9 3102 case OP_VAR_VALUE:
4c4b4cd2 3103 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
3104 {
3105 struct ada_symbol_info *candidates;
3106 int n_candidates;
3107
3108 n_candidates =
3109 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3110 (exp->elts[pc + 2].symbol),
3111 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3112 &candidates);
76a01679
JB
3113
3114 if (n_candidates > 1)
3115 {
3116 /* Types tend to get re-introduced locally, so if there
3117 are any local symbols that are not types, first filter
3118 out all types. */
3119 int j;
3120 for (j = 0; j < n_candidates; j += 1)
3121 switch (SYMBOL_CLASS (candidates[j].sym))
3122 {
3123 case LOC_REGISTER:
3124 case LOC_ARG:
3125 case LOC_REF_ARG:
76a01679
JB
3126 case LOC_REGPARM_ADDR:
3127 case LOC_LOCAL:
76a01679 3128 case LOC_COMPUTED:
76a01679
JB
3129 goto FoundNonType;
3130 default:
3131 break;
3132 }
3133 FoundNonType:
3134 if (j < n_candidates)
3135 {
3136 j = 0;
3137 while (j < n_candidates)
3138 {
3139 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
3140 {
3141 candidates[j] = candidates[n_candidates - 1];
3142 n_candidates -= 1;
3143 }
3144 else
3145 j += 1;
3146 }
3147 }
3148 }
3149
3150 if (n_candidates == 0)
323e0a4a 3151 error (_("No definition found for %s"),
76a01679
JB
3152 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3153 else if (n_candidates == 1)
3154 i = 0;
3155 else if (deprocedure_p
3156 && !is_nonfunction (candidates, n_candidates))
3157 {
06d5cf63
JB
3158 i = ada_resolve_function
3159 (candidates, n_candidates, NULL, 0,
3160 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3161 context_type);
76a01679 3162 if (i < 0)
323e0a4a 3163 error (_("Could not find a match for %s"),
76a01679
JB
3164 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3165 }
3166 else
3167 {
323e0a4a 3168 printf_filtered (_("Multiple matches for %s\n"),
76a01679
JB
3169 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3170 user_select_syms (candidates, n_candidates, 1);
3171 i = 0;
3172 }
3173
3174 exp->elts[pc + 1].block = candidates[i].block;
3175 exp->elts[pc + 2].symbol = candidates[i].sym;
1265e4aa
JB
3176 if (innermost_block == NULL
3177 || contained_in (candidates[i].block, innermost_block))
76a01679
JB
3178 innermost_block = candidates[i].block;
3179 }
3180
3181 if (deprocedure_p
3182 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3183 == TYPE_CODE_FUNC))
3184 {
3185 replace_operator_with_call (expp, pc, 0, 0,
3186 exp->elts[pc + 2].symbol,
3187 exp->elts[pc + 1].block);
3188 exp = *expp;
3189 }
14f9c5c9
AS
3190 break;
3191
3192 case OP_FUNCALL:
3193 {
4c4b4cd2 3194 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3195 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2
PH
3196 {
3197 struct ada_symbol_info *candidates;
3198 int n_candidates;
3199
3200 n_candidates =
76a01679
JB
3201 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3202 (exp->elts[pc + 5].symbol),
3203 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3204 &candidates);
4c4b4cd2
PH
3205 if (n_candidates == 1)
3206 i = 0;
3207 else
3208 {
06d5cf63
JB
3209 i = ada_resolve_function
3210 (candidates, n_candidates,
3211 argvec, nargs,
3212 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3213 context_type);
4c4b4cd2 3214 if (i < 0)
323e0a4a 3215 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3216 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3217 }
3218
3219 exp->elts[pc + 4].block = candidates[i].block;
3220 exp->elts[pc + 5].symbol = candidates[i].sym;
1265e4aa
JB
3221 if (innermost_block == NULL
3222 || contained_in (candidates[i].block, innermost_block))
4c4b4cd2
PH
3223 innermost_block = candidates[i].block;
3224 }
14f9c5c9
AS
3225 }
3226 break;
3227 case BINOP_ADD:
3228 case BINOP_SUB:
3229 case BINOP_MUL:
3230 case BINOP_DIV:
3231 case BINOP_REM:
3232 case BINOP_MOD:
3233 case BINOP_CONCAT:
3234 case BINOP_BITWISE_AND:
3235 case BINOP_BITWISE_IOR:
3236 case BINOP_BITWISE_XOR:
3237 case BINOP_EQUAL:
3238 case BINOP_NOTEQUAL:
3239 case BINOP_LESS:
3240 case BINOP_GTR:
3241 case BINOP_LEQ:
3242 case BINOP_GEQ:
3243 case BINOP_EXP:
3244 case UNOP_NEG:
3245 case UNOP_PLUS:
3246 case UNOP_LOGICAL_NOT:
3247 case UNOP_ABS:
3248 if (possible_user_operator_p (op, argvec))
4c4b4cd2
PH
3249 {
3250 struct ada_symbol_info *candidates;
3251 int n_candidates;
3252
3253 n_candidates =
3254 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3255 (struct block *) NULL, VAR_DOMAIN,
4eeaa230 3256 &candidates);
4c4b4cd2 3257 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
76a01679 3258 ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3259 if (i < 0)
3260 break;
3261
76a01679
JB
3262 replace_operator_with_call (expp, pc, nargs, 1,
3263 candidates[i].sym, candidates[i].block);
4c4b4cd2
PH
3264 exp = *expp;
3265 }
14f9c5c9 3266 break;
4c4b4cd2
PH
3267
3268 case OP_TYPE:
b3dbf008 3269 case OP_REGISTER:
4c4b4cd2 3270 return NULL;
14f9c5c9
AS
3271 }
3272
3273 *pos = pc;
3274 return evaluate_subexp_type (exp, pos);
3275}
3276
3277/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3278 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3279 a non-pointer. */
14f9c5c9 3280/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3281 liberal. */
14f9c5c9
AS
3282
3283static int
4dc81987 3284ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3285{
61ee279c
PH
3286 ftype = ada_check_typedef (ftype);
3287 atype = ada_check_typedef (atype);
14f9c5c9
AS
3288
3289 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3290 ftype = TYPE_TARGET_TYPE (ftype);
3291 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3292 atype = TYPE_TARGET_TYPE (atype);
3293
d2e4a39e 3294 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3295 {
3296 default:
5b3d5b7d 3297 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3298 case TYPE_CODE_PTR:
3299 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3300 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3301 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3302 else
1265e4aa
JB
3303 return (may_deref
3304 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3305 case TYPE_CODE_INT:
3306 case TYPE_CODE_ENUM:
3307 case TYPE_CODE_RANGE:
3308 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3309 {
3310 case TYPE_CODE_INT:
3311 case TYPE_CODE_ENUM:
3312 case TYPE_CODE_RANGE:
3313 return 1;
3314 default:
3315 return 0;
3316 }
14f9c5c9
AS
3317
3318 case TYPE_CODE_ARRAY:
d2e4a39e 3319 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3320 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3321
3322 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3323 if (ada_is_array_descriptor_type (ftype))
3324 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3325 || ada_is_array_descriptor_type (atype));
14f9c5c9 3326 else
4c4b4cd2
PH
3327 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3328 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3329
3330 case TYPE_CODE_UNION:
3331 case TYPE_CODE_FLT:
3332 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3333 }
3334}
3335
3336/* Return non-zero if the formals of FUNC "sufficiently match" the
3337 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3338 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3339 argument function. */
14f9c5c9
AS
3340
3341static int
d2e4a39e 3342ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3343{
3344 int i;
d2e4a39e 3345 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3346
1265e4aa
JB
3347 if (SYMBOL_CLASS (func) == LOC_CONST
3348 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3349 return (n_actuals == 0);
3350 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3351 return 0;
3352
3353 if (TYPE_NFIELDS (func_type) != n_actuals)
3354 return 0;
3355
3356 for (i = 0; i < n_actuals; i += 1)
3357 {
4c4b4cd2 3358 if (actuals[i] == NULL)
76a01679
JB
3359 return 0;
3360 else
3361 {
5b4ee69b
MS
3362 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3363 i));
df407dfe 3364 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3365
76a01679
JB
3366 if (!ada_type_match (ftype, atype, 1))
3367 return 0;
3368 }
14f9c5c9
AS
3369 }
3370 return 1;
3371}
3372
3373/* False iff function type FUNC_TYPE definitely does not produce a value
3374 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3375 FUNC_TYPE is not a valid function type with a non-null return type
3376 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3377
3378static int
d2e4a39e 3379return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3380{
d2e4a39e 3381 struct type *return_type;
14f9c5c9
AS
3382
3383 if (func_type == NULL)
3384 return 1;
3385
4c4b4cd2 3386 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3387 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3388 else
18af8284 3389 return_type = get_base_type (func_type);
14f9c5c9
AS
3390 if (return_type == NULL)
3391 return 1;
3392
18af8284 3393 context_type = get_base_type (context_type);
14f9c5c9
AS
3394
3395 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3396 return context_type == NULL || return_type == context_type;
3397 else if (context_type == NULL)
3398 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3399 else
3400 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3401}
3402
3403
4c4b4cd2 3404/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3405 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3406 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3407 that returns that type, then eliminate matches that don't. If
3408 CONTEXT_TYPE is void and there is at least one match that does not
3409 return void, eliminate all matches that do.
3410
14f9c5c9
AS
3411 Asks the user if there is more than one match remaining. Returns -1
3412 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3413 solely for messages. May re-arrange and modify SYMS in
3414 the process; the index returned is for the modified vector. */
14f9c5c9 3415
4c4b4cd2
PH
3416static int
3417ada_resolve_function (struct ada_symbol_info syms[],
3418 int nsyms, struct value **args, int nargs,
3419 const char *name, struct type *context_type)
14f9c5c9 3420{
30b15541 3421 int fallback;
14f9c5c9 3422 int k;
4c4b4cd2 3423 int m; /* Number of hits */
14f9c5c9 3424
d2e4a39e 3425 m = 0;
30b15541
UW
3426 /* In the first pass of the loop, we only accept functions matching
3427 context_type. If none are found, we add a second pass of the loop
3428 where every function is accepted. */
3429 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3430 {
3431 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3432 {
61ee279c 3433 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
4c4b4cd2
PH
3434
3435 if (ada_args_match (syms[k].sym, args, nargs)
30b15541 3436 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3437 {
3438 syms[m] = syms[k];
3439 m += 1;
3440 }
3441 }
14f9c5c9
AS
3442 }
3443
3444 if (m == 0)
3445 return -1;
3446 else if (m > 1)
3447 {
323e0a4a 3448 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3449 user_select_syms (syms, m, 1);
14f9c5c9
AS
3450 return 0;
3451 }
3452 return 0;
3453}
3454
4c4b4cd2
PH
3455/* Returns true (non-zero) iff decoded name N0 should appear before N1
3456 in a listing of choices during disambiguation (see sort_choices, below).
3457 The idea is that overloadings of a subprogram name from the
3458 same package should sort in their source order. We settle for ordering
3459 such symbols by their trailing number (__N or $N). */
3460
14f9c5c9 3461static int
0d5cff50 3462encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3463{
3464 if (N1 == NULL)
3465 return 0;
3466 else if (N0 == NULL)
3467 return 1;
3468 else
3469 {
3470 int k0, k1;
5b4ee69b 3471
d2e4a39e 3472 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3473 ;
d2e4a39e 3474 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3475 ;
d2e4a39e 3476 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3477 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3478 {
3479 int n0, n1;
5b4ee69b 3480
4c4b4cd2
PH
3481 n0 = k0;
3482 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3483 n0 -= 1;
3484 n1 = k1;
3485 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3486 n1 -= 1;
3487 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3488 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3489 }
14f9c5c9
AS
3490 return (strcmp (N0, N1) < 0);
3491 }
3492}
d2e4a39e 3493
4c4b4cd2
PH
3494/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3495 encoded names. */
3496
d2e4a39e 3497static void
4c4b4cd2 3498sort_choices (struct ada_symbol_info syms[], int nsyms)
14f9c5c9 3499{
4c4b4cd2 3500 int i;
5b4ee69b 3501
d2e4a39e 3502 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3503 {
4c4b4cd2 3504 struct ada_symbol_info sym = syms[i];
14f9c5c9
AS
3505 int j;
3506
d2e4a39e 3507 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2
PH
3508 {
3509 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3510 SYMBOL_LINKAGE_NAME (sym.sym)))
3511 break;
3512 syms[j + 1] = syms[j];
3513 }
d2e4a39e 3514 syms[j + 1] = sym;
14f9c5c9
AS
3515 }
3516}
3517
4c4b4cd2
PH
3518/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3519 by asking the user (if necessary), returning the number selected,
3520 and setting the first elements of SYMS items. Error if no symbols
3521 selected. */
14f9c5c9
AS
3522
3523/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3524 to be re-integrated one of these days. */
14f9c5c9
AS
3525
3526int
4c4b4cd2 3527user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
14f9c5c9
AS
3528{
3529 int i;
d2e4a39e 3530 int *chosen = (int *) alloca (sizeof (int) * nsyms);
14f9c5c9
AS
3531 int n_chosen;
3532 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3533 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3534
3535 if (max_results < 1)
323e0a4a 3536 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3537 if (nsyms <= 1)
3538 return nsyms;
3539
717d2f5a
JB
3540 if (select_mode == multiple_symbols_cancel)
3541 error (_("\
3542canceled because the command is ambiguous\n\
3543See set/show multiple-symbol."));
3544
3545 /* If select_mode is "all", then return all possible symbols.
3546 Only do that if more than one symbol can be selected, of course.
3547 Otherwise, display the menu as usual. */
3548 if (select_mode == multiple_symbols_all && max_results > 1)
3549 return nsyms;
3550
323e0a4a 3551 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3552 if (max_results > 1)
323e0a4a 3553 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3554
4c4b4cd2 3555 sort_choices (syms, nsyms);
14f9c5c9
AS
3556
3557 for (i = 0; i < nsyms; i += 1)
3558 {
4c4b4cd2
PH
3559 if (syms[i].sym == NULL)
3560 continue;
3561
3562 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3563 {
76a01679
JB
3564 struct symtab_and_line sal =
3565 find_function_start_sal (syms[i].sym, 1);
5b4ee69b 3566
323e0a4a
AC
3567 if (sal.symtab == NULL)
3568 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3569 i + first_choice,
3570 SYMBOL_PRINT_NAME (syms[i].sym),
3571 sal.line);
3572 else
3573 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3574 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821
JK
3575 symtab_to_filename_for_display (sal.symtab),
3576 sal.line);
4c4b4cd2
PH
3577 continue;
3578 }
d2e4a39e 3579 else
4c4b4cd2
PH
3580 {
3581 int is_enumeral =
3582 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3583 && SYMBOL_TYPE (syms[i].sym) != NULL
3584 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
210bbc17 3585 struct symtab *symtab = SYMBOL_SYMTAB (syms[i].sym);
4c4b4cd2
PH
3586
3587 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
323e0a4a 3588 printf_unfiltered (_("[%d] %s at %s:%d\n"),
4c4b4cd2
PH
3589 i + first_choice,
3590 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821
JK
3591 symtab_to_filename_for_display (symtab),
3592 SYMBOL_LINE (syms[i].sym));
76a01679
JB
3593 else if (is_enumeral
3594 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
4c4b4cd2 3595 {
a3f17187 3596 printf_unfiltered (("[%d] "), i + first_choice);
76a01679 3597 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
79d43c61 3598 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3599 printf_unfiltered (_("'(%s) (enumeral)\n"),
4c4b4cd2
PH
3600 SYMBOL_PRINT_NAME (syms[i].sym));
3601 }
3602 else if (symtab != NULL)
3603 printf_unfiltered (is_enumeral
323e0a4a
AC
3604 ? _("[%d] %s in %s (enumeral)\n")
3605 : _("[%d] %s at %s:?\n"),
4c4b4cd2
PH
3606 i + first_choice,
3607 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821 3608 symtab_to_filename_for_display (symtab));
4c4b4cd2
PH
3609 else
3610 printf_unfiltered (is_enumeral
323e0a4a
AC
3611 ? _("[%d] %s (enumeral)\n")
3612 : _("[%d] %s at ?\n"),
4c4b4cd2
PH
3613 i + first_choice,
3614 SYMBOL_PRINT_NAME (syms[i].sym));
3615 }
14f9c5c9 3616 }
d2e4a39e 3617
14f9c5c9 3618 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 3619 "overload-choice");
14f9c5c9
AS
3620
3621 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 3622 syms[i] = syms[chosen[i]];
14f9c5c9
AS
3623
3624 return n_chosen;
3625}
3626
3627/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 3628 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
3629 order in CHOICES[0 .. N-1], and return N.
3630
3631 The user types choices as a sequence of numbers on one line
3632 separated by blanks, encoding them as follows:
3633
4c4b4cd2 3634 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
3635 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3636 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3637
4c4b4cd2 3638 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
3639
3640 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 3641 prompts (for use with the -f switch). */
14f9c5c9
AS
3642
3643int
d2e4a39e 3644get_selections (int *choices, int n_choices, int max_results,
4c4b4cd2 3645 int is_all_choice, char *annotation_suffix)
14f9c5c9 3646{
d2e4a39e 3647 char *args;
0bcd0149 3648 char *prompt;
14f9c5c9
AS
3649 int n_chosen;
3650 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 3651
14f9c5c9
AS
3652 prompt = getenv ("PS2");
3653 if (prompt == NULL)
0bcd0149 3654 prompt = "> ";
14f9c5c9 3655
0bcd0149 3656 args = command_line_input (prompt, 0, annotation_suffix);
d2e4a39e 3657
14f9c5c9 3658 if (args == NULL)
323e0a4a 3659 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
3660
3661 n_chosen = 0;
76a01679 3662
4c4b4cd2
PH
3663 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3664 order, as given in args. Choices are validated. */
14f9c5c9
AS
3665 while (1)
3666 {
d2e4a39e 3667 char *args2;
14f9c5c9
AS
3668 int choice, j;
3669
0fcd72ba 3670 args = skip_spaces (args);
14f9c5c9 3671 if (*args == '\0' && n_chosen == 0)
323e0a4a 3672 error_no_arg (_("one or more choice numbers"));
14f9c5c9 3673 else if (*args == '\0')
4c4b4cd2 3674 break;
14f9c5c9
AS
3675
3676 choice = strtol (args, &args2, 10);
d2e4a39e 3677 if (args == args2 || choice < 0
4c4b4cd2 3678 || choice > n_choices + first_choice - 1)
323e0a4a 3679 error (_("Argument must be choice number"));
14f9c5c9
AS
3680 args = args2;
3681
d2e4a39e 3682 if (choice == 0)
323e0a4a 3683 error (_("cancelled"));
14f9c5c9
AS
3684
3685 if (choice < first_choice)
4c4b4cd2
PH
3686 {
3687 n_chosen = n_choices;
3688 for (j = 0; j < n_choices; j += 1)
3689 choices[j] = j;
3690 break;
3691 }
14f9c5c9
AS
3692 choice -= first_choice;
3693
d2e4a39e 3694 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
3695 {
3696 }
14f9c5c9
AS
3697
3698 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
3699 {
3700 int k;
5b4ee69b 3701
4c4b4cd2
PH
3702 for (k = n_chosen - 1; k > j; k -= 1)
3703 choices[k + 1] = choices[k];
3704 choices[j + 1] = choice;
3705 n_chosen += 1;
3706 }
14f9c5c9
AS
3707 }
3708
3709 if (n_chosen > max_results)
323e0a4a 3710 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 3711
14f9c5c9
AS
3712 return n_chosen;
3713}
3714
4c4b4cd2
PH
3715/* Replace the operator of length OPLEN at position PC in *EXPP with a call
3716 on the function identified by SYM and BLOCK, and taking NARGS
3717 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
3718
3719static void
d2e4a39e 3720replace_operator_with_call (struct expression **expp, int pc, int nargs,
4c4b4cd2 3721 int oplen, struct symbol *sym,
270140bd 3722 const struct block *block)
14f9c5c9
AS
3723{
3724 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 3725 symbol, -oplen for operator being replaced). */
d2e4a39e 3726 struct expression *newexp = (struct expression *)
8c1a34e7 3727 xzalloc (sizeof (struct expression)
4c4b4cd2 3728 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
d2e4a39e 3729 struct expression *exp = *expp;
14f9c5c9
AS
3730
3731 newexp->nelts = exp->nelts + 7 - oplen;
3732 newexp->language_defn = exp->language_defn;
3489610d 3733 newexp->gdbarch = exp->gdbarch;
14f9c5c9 3734 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 3735 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 3736 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
3737
3738 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3739 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3740
3741 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3742 newexp->elts[pc + 4].block = block;
3743 newexp->elts[pc + 5].symbol = sym;
3744
3745 *expp = newexp;
aacb1f0a 3746 xfree (exp);
d2e4a39e 3747}
14f9c5c9
AS
3748
3749/* Type-class predicates */
3750
4c4b4cd2
PH
3751/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3752 or FLOAT). */
14f9c5c9
AS
3753
3754static int
d2e4a39e 3755numeric_type_p (struct type *type)
14f9c5c9
AS
3756{
3757 if (type == NULL)
3758 return 0;
d2e4a39e
AS
3759 else
3760 {
3761 switch (TYPE_CODE (type))
4c4b4cd2
PH
3762 {
3763 case TYPE_CODE_INT:
3764 case TYPE_CODE_FLT:
3765 return 1;
3766 case TYPE_CODE_RANGE:
3767 return (type == TYPE_TARGET_TYPE (type)
3768 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3769 default:
3770 return 0;
3771 }
d2e4a39e 3772 }
14f9c5c9
AS
3773}
3774
4c4b4cd2 3775/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
3776
3777static int
d2e4a39e 3778integer_type_p (struct type *type)
14f9c5c9
AS
3779{
3780 if (type == NULL)
3781 return 0;
d2e4a39e
AS
3782 else
3783 {
3784 switch (TYPE_CODE (type))
4c4b4cd2
PH
3785 {
3786 case TYPE_CODE_INT:
3787 return 1;
3788 case TYPE_CODE_RANGE:
3789 return (type == TYPE_TARGET_TYPE (type)
3790 || integer_type_p (TYPE_TARGET_TYPE (type)));
3791 default:
3792 return 0;
3793 }
d2e4a39e 3794 }
14f9c5c9
AS
3795}
3796
4c4b4cd2 3797/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
3798
3799static int
d2e4a39e 3800scalar_type_p (struct type *type)
14f9c5c9
AS
3801{
3802 if (type == NULL)
3803 return 0;
d2e4a39e
AS
3804 else
3805 {
3806 switch (TYPE_CODE (type))
4c4b4cd2
PH
3807 {
3808 case TYPE_CODE_INT:
3809 case TYPE_CODE_RANGE:
3810 case TYPE_CODE_ENUM:
3811 case TYPE_CODE_FLT:
3812 return 1;
3813 default:
3814 return 0;
3815 }
d2e4a39e 3816 }
14f9c5c9
AS
3817}
3818
4c4b4cd2 3819/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
3820
3821static int
d2e4a39e 3822discrete_type_p (struct type *type)
14f9c5c9
AS
3823{
3824 if (type == NULL)
3825 return 0;
d2e4a39e
AS
3826 else
3827 {
3828 switch (TYPE_CODE (type))
4c4b4cd2
PH
3829 {
3830 case TYPE_CODE_INT:
3831 case TYPE_CODE_RANGE:
3832 case TYPE_CODE_ENUM:
872f0337 3833 case TYPE_CODE_BOOL:
4c4b4cd2
PH
3834 return 1;
3835 default:
3836 return 0;
3837 }
d2e4a39e 3838 }
14f9c5c9
AS
3839}
3840
4c4b4cd2
PH
3841/* Returns non-zero if OP with operands in the vector ARGS could be
3842 a user-defined function. Errs on the side of pre-defined operators
3843 (i.e., result 0). */
14f9c5c9
AS
3844
3845static int
d2e4a39e 3846possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 3847{
76a01679 3848 struct type *type0 =
df407dfe 3849 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 3850 struct type *type1 =
df407dfe 3851 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 3852
4c4b4cd2
PH
3853 if (type0 == NULL)
3854 return 0;
3855
14f9c5c9
AS
3856 switch (op)
3857 {
3858 default:
3859 return 0;
3860
3861 case BINOP_ADD:
3862 case BINOP_SUB:
3863 case BINOP_MUL:
3864 case BINOP_DIV:
d2e4a39e 3865 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
3866
3867 case BINOP_REM:
3868 case BINOP_MOD:
3869 case BINOP_BITWISE_AND:
3870 case BINOP_BITWISE_IOR:
3871 case BINOP_BITWISE_XOR:
d2e4a39e 3872 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3873
3874 case BINOP_EQUAL:
3875 case BINOP_NOTEQUAL:
3876 case BINOP_LESS:
3877 case BINOP_GTR:
3878 case BINOP_LEQ:
3879 case BINOP_GEQ:
d2e4a39e 3880 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
3881
3882 case BINOP_CONCAT:
ee90b9ab 3883 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
3884
3885 case BINOP_EXP:
d2e4a39e 3886 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3887
3888 case UNOP_NEG:
3889 case UNOP_PLUS:
3890 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
3891 case UNOP_ABS:
3892 return (!numeric_type_p (type0));
14f9c5c9
AS
3893
3894 }
3895}
3896\f
4c4b4cd2 3897 /* Renaming */
14f9c5c9 3898
aeb5907d
JB
3899/* NOTES:
3900
3901 1. In the following, we assume that a renaming type's name may
3902 have an ___XD suffix. It would be nice if this went away at some
3903 point.
3904 2. We handle both the (old) purely type-based representation of
3905 renamings and the (new) variable-based encoding. At some point,
3906 it is devoutly to be hoped that the former goes away
3907 (FIXME: hilfinger-2007-07-09).
3908 3. Subprogram renamings are not implemented, although the XRS
3909 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3910
3911/* If SYM encodes a renaming,
3912
3913 <renaming> renames <renamed entity>,
3914
3915 sets *LEN to the length of the renamed entity's name,
3916 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3917 the string describing the subcomponent selected from the renamed
0963b4bd 3918 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
3919 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3920 are undefined). Otherwise, returns a value indicating the category
3921 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3922 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3923 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3924 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3925 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3926 may be NULL, in which case they are not assigned.
3927
3928 [Currently, however, GCC does not generate subprogram renamings.] */
3929
3930enum ada_renaming_category
3931ada_parse_renaming (struct symbol *sym,
3932 const char **renamed_entity, int *len,
3933 const char **renaming_expr)
3934{
3935 enum ada_renaming_category kind;
3936 const char *info;
3937 const char *suffix;
3938
3939 if (sym == NULL)
3940 return ADA_NOT_RENAMING;
3941 switch (SYMBOL_CLASS (sym))
14f9c5c9 3942 {
aeb5907d
JB
3943 default:
3944 return ADA_NOT_RENAMING;
3945 case LOC_TYPEDEF:
3946 return parse_old_style_renaming (SYMBOL_TYPE (sym),
3947 renamed_entity, len, renaming_expr);
3948 case LOC_LOCAL:
3949 case LOC_STATIC:
3950 case LOC_COMPUTED:
3951 case LOC_OPTIMIZED_OUT:
3952 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
3953 if (info == NULL)
3954 return ADA_NOT_RENAMING;
3955 switch (info[5])
3956 {
3957 case '_':
3958 kind = ADA_OBJECT_RENAMING;
3959 info += 6;
3960 break;
3961 case 'E':
3962 kind = ADA_EXCEPTION_RENAMING;
3963 info += 7;
3964 break;
3965 case 'P':
3966 kind = ADA_PACKAGE_RENAMING;
3967 info += 7;
3968 break;
3969 case 'S':
3970 kind = ADA_SUBPROGRAM_RENAMING;
3971 info += 7;
3972 break;
3973 default:
3974 return ADA_NOT_RENAMING;
3975 }
14f9c5c9 3976 }
4c4b4cd2 3977
aeb5907d
JB
3978 if (renamed_entity != NULL)
3979 *renamed_entity = info;
3980 suffix = strstr (info, "___XE");
3981 if (suffix == NULL || suffix == info)
3982 return ADA_NOT_RENAMING;
3983 if (len != NULL)
3984 *len = strlen (info) - strlen (suffix);
3985 suffix += 5;
3986 if (renaming_expr != NULL)
3987 *renaming_expr = suffix;
3988 return kind;
3989}
3990
3991/* Assuming TYPE encodes a renaming according to the old encoding in
3992 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3993 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3994 ADA_NOT_RENAMING otherwise. */
3995static enum ada_renaming_category
3996parse_old_style_renaming (struct type *type,
3997 const char **renamed_entity, int *len,
3998 const char **renaming_expr)
3999{
4000 enum ada_renaming_category kind;
4001 const char *name;
4002 const char *info;
4003 const char *suffix;
14f9c5c9 4004
aeb5907d
JB
4005 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4006 || TYPE_NFIELDS (type) != 1)
4007 return ADA_NOT_RENAMING;
14f9c5c9 4008
aeb5907d
JB
4009 name = type_name_no_tag (type);
4010 if (name == NULL)
4011 return ADA_NOT_RENAMING;
4012
4013 name = strstr (name, "___XR");
4014 if (name == NULL)
4015 return ADA_NOT_RENAMING;
4016 switch (name[5])
4017 {
4018 case '\0':
4019 case '_':
4020 kind = ADA_OBJECT_RENAMING;
4021 break;
4022 case 'E':
4023 kind = ADA_EXCEPTION_RENAMING;
4024 break;
4025 case 'P':
4026 kind = ADA_PACKAGE_RENAMING;
4027 break;
4028 case 'S':
4029 kind = ADA_SUBPROGRAM_RENAMING;
4030 break;
4031 default:
4032 return ADA_NOT_RENAMING;
4033 }
14f9c5c9 4034
aeb5907d
JB
4035 info = TYPE_FIELD_NAME (type, 0);
4036 if (info == NULL)
4037 return ADA_NOT_RENAMING;
4038 if (renamed_entity != NULL)
4039 *renamed_entity = info;
4040 suffix = strstr (info, "___XE");
4041 if (renaming_expr != NULL)
4042 *renaming_expr = suffix + 5;
4043 if (suffix == NULL || suffix == info)
4044 return ADA_NOT_RENAMING;
4045 if (len != NULL)
4046 *len = suffix - info;
4047 return kind;
a5ee536b
JB
4048}
4049
4050/* Compute the value of the given RENAMING_SYM, which is expected to
4051 be a symbol encoding a renaming expression. BLOCK is the block
4052 used to evaluate the renaming. */
52ce6436 4053
a5ee536b
JB
4054static struct value *
4055ada_read_renaming_var_value (struct symbol *renaming_sym,
4056 struct block *block)
4057{
bbc13ae3 4058 const char *sym_name;
a5ee536b
JB
4059 struct expression *expr;
4060 struct value *value;
4061 struct cleanup *old_chain = NULL;
4062
bbc13ae3 4063 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
1bb9788d 4064 expr = parse_exp_1 (&sym_name, 0, block, 0);
bbc13ae3 4065 old_chain = make_cleanup (free_current_contents, &expr);
a5ee536b
JB
4066 value = evaluate_expression (expr);
4067
4068 do_cleanups (old_chain);
4069 return value;
4070}
14f9c5c9 4071\f
d2e4a39e 4072
4c4b4cd2 4073 /* Evaluation: Function Calls */
14f9c5c9 4074
4c4b4cd2 4075/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4076 lvalues, and otherwise has the side-effect of allocating memory
4077 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4078
d2e4a39e 4079static struct value *
40bc484c 4080ensure_lval (struct value *val)
14f9c5c9 4081{
40bc484c
JB
4082 if (VALUE_LVAL (val) == not_lval
4083 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4084 {
df407dfe 4085 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4086 const CORE_ADDR addr =
4087 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4088
40bc484c 4089 set_value_address (val, addr);
a84a8a0d 4090 VALUE_LVAL (val) = lval_memory;
40bc484c 4091 write_memory (addr, value_contents (val), len);
c3e5cd34 4092 }
14f9c5c9
AS
4093
4094 return val;
4095}
4096
4097/* Return the value ACTUAL, converted to be an appropriate value for a
4098 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4099 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4100 values not residing in memory, updating it as needed. */
14f9c5c9 4101
a93c0eb6 4102struct value *
40bc484c 4103ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4104{
df407dfe 4105 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4106 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4107 struct type *formal_target =
4108 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4109 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4110 struct type *actual_target =
4111 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4112 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4113
4c4b4cd2 4114 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4115 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4116 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4117 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4118 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4119 {
a84a8a0d 4120 struct value *result;
5b4ee69b 4121
14f9c5c9 4122 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4123 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4124 result = desc_data (actual);
14f9c5c9 4125 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4126 {
4127 if (VALUE_LVAL (actual) != lval_memory)
4128 {
4129 struct value *val;
5b4ee69b 4130
df407dfe 4131 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4132 val = allocate_value (actual_type);
990a07ab 4133 memcpy ((char *) value_contents_raw (val),
0fd88904 4134 (char *) value_contents (actual),
4c4b4cd2 4135 TYPE_LENGTH (actual_type));
40bc484c 4136 actual = ensure_lval (val);
4c4b4cd2 4137 }
a84a8a0d 4138 result = value_addr (actual);
4c4b4cd2 4139 }
a84a8a0d
JB
4140 else
4141 return actual;
b1af9e97 4142 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4143 }
4144 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4145 return ada_value_ind (actual);
4146
4147 return actual;
4148}
4149
438c98a1
JB
4150/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4151 type TYPE. This is usually an inefficient no-op except on some targets
4152 (such as AVR) where the representation of a pointer and an address
4153 differs. */
4154
4155static CORE_ADDR
4156value_pointer (struct value *value, struct type *type)
4157{
4158 struct gdbarch *gdbarch = get_type_arch (type);
4159 unsigned len = TYPE_LENGTH (type);
4160 gdb_byte *buf = alloca (len);
4161 CORE_ADDR addr;
4162
4163 addr = value_address (value);
4164 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4165 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4166 return addr;
4167}
4168
14f9c5c9 4169
4c4b4cd2
PH
4170/* Push a descriptor of type TYPE for array value ARR on the stack at
4171 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4172 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4173 to-descriptor type rather than a descriptor type), a struct value *
4174 representing a pointer to this descriptor. */
14f9c5c9 4175
d2e4a39e 4176static struct value *
40bc484c 4177make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4178{
d2e4a39e
AS
4179 struct type *bounds_type = desc_bounds_type (type);
4180 struct type *desc_type = desc_base_type (type);
4181 struct value *descriptor = allocate_value (desc_type);
4182 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4183 int i;
d2e4a39e 4184
0963b4bd
MS
4185 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4186 i > 0; i -= 1)
14f9c5c9 4187 {
19f220c3
JK
4188 modify_field (value_type (bounds), value_contents_writeable (bounds),
4189 ada_array_bound (arr, i, 0),
4190 desc_bound_bitpos (bounds_type, i, 0),
4191 desc_bound_bitsize (bounds_type, i, 0));
4192 modify_field (value_type (bounds), value_contents_writeable (bounds),
4193 ada_array_bound (arr, i, 1),
4194 desc_bound_bitpos (bounds_type, i, 1),
4195 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4196 }
d2e4a39e 4197
40bc484c 4198 bounds = ensure_lval (bounds);
d2e4a39e 4199
19f220c3
JK
4200 modify_field (value_type (descriptor),
4201 value_contents_writeable (descriptor),
4202 value_pointer (ensure_lval (arr),
4203 TYPE_FIELD_TYPE (desc_type, 0)),
4204 fat_pntr_data_bitpos (desc_type),
4205 fat_pntr_data_bitsize (desc_type));
4206
4207 modify_field (value_type (descriptor),
4208 value_contents_writeable (descriptor),
4209 value_pointer (bounds,
4210 TYPE_FIELD_TYPE (desc_type, 1)),
4211 fat_pntr_bounds_bitpos (desc_type),
4212 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4213
40bc484c 4214 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4215
4216 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4217 return value_addr (descriptor);
4218 else
4219 return descriptor;
4220}
14f9c5c9 4221\f
963a6417 4222/* Dummy definitions for an experimental caching module that is not
0963b4bd 4223 * used in the public sources. */
96d887e8 4224
96d887e8
PH
4225static int
4226lookup_cached_symbol (const char *name, domain_enum namespace,
2570f2b7 4227 struct symbol **sym, struct block **block)
96d887e8
PH
4228{
4229 return 0;
4230}
4231
4232static void
4233cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
270140bd 4234 const struct block *block)
96d887e8
PH
4235{
4236}
4c4b4cd2
PH
4237\f
4238 /* Symbol Lookup */
4239
c0431670
JB
4240/* Return nonzero if wild matching should be used when searching for
4241 all symbols matching LOOKUP_NAME.
4242
4243 LOOKUP_NAME is expected to be a symbol name after transformation
4244 for Ada lookups (see ada_name_for_lookup). */
4245
4246static int
4247should_use_wild_match (const char *lookup_name)
4248{
4249 return (strstr (lookup_name, "__") == NULL);
4250}
4251
4c4b4cd2
PH
4252/* Return the result of a standard (literal, C-like) lookup of NAME in
4253 given DOMAIN, visible from lexical block BLOCK. */
4254
4255static struct symbol *
4256standard_lookup (const char *name, const struct block *block,
4257 domain_enum domain)
4258{
acbd605d
MGD
4259 /* Initialize it just to avoid a GCC false warning. */
4260 struct symbol *sym = NULL;
4c4b4cd2 4261
2570f2b7 4262 if (lookup_cached_symbol (name, domain, &sym, NULL))
4c4b4cd2 4263 return sym;
2570f2b7
UW
4264 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4265 cache_symbol (name, domain, sym, block_found);
4c4b4cd2
PH
4266 return sym;
4267}
4268
4269
4270/* Non-zero iff there is at least one non-function/non-enumeral symbol
4271 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4272 since they contend in overloading in the same way. */
4273static int
4274is_nonfunction (struct ada_symbol_info syms[], int n)
4275{
4276 int i;
4277
4278 for (i = 0; i < n; i += 1)
4279 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
4280 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
4281 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
14f9c5c9
AS
4282 return 1;
4283
4284 return 0;
4285}
4286
4287/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4288 struct types. Otherwise, they may not. */
14f9c5c9
AS
4289
4290static int
d2e4a39e 4291equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4292{
d2e4a39e 4293 if (type0 == type1)
14f9c5c9 4294 return 1;
d2e4a39e 4295 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4296 || TYPE_CODE (type0) != TYPE_CODE (type1))
4297 return 0;
d2e4a39e 4298 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4299 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4300 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4301 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4302 return 1;
d2e4a39e 4303
14f9c5c9
AS
4304 return 0;
4305}
4306
4307/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4308 no more defined than that of SYM1. */
14f9c5c9
AS
4309
4310static int
d2e4a39e 4311lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4312{
4313 if (sym0 == sym1)
4314 return 1;
176620f1 4315 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4316 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4317 return 0;
4318
d2e4a39e 4319 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4320 {
4321 case LOC_UNDEF:
4322 return 1;
4323 case LOC_TYPEDEF:
4324 {
4c4b4cd2
PH
4325 struct type *type0 = SYMBOL_TYPE (sym0);
4326 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4327 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4328 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4329 int len0 = strlen (name0);
5b4ee69b 4330
4c4b4cd2
PH
4331 return
4332 TYPE_CODE (type0) == TYPE_CODE (type1)
4333 && (equiv_types (type0, type1)
4334 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4335 && strncmp (name1 + len0, "___XV", 5) == 0));
14f9c5c9
AS
4336 }
4337 case LOC_CONST:
4338 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4339 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4340 default:
4341 return 0;
14f9c5c9
AS
4342 }
4343}
4344
4c4b4cd2
PH
4345/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4346 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4347
4348static void
76a01679
JB
4349add_defn_to_vec (struct obstack *obstackp,
4350 struct symbol *sym,
2570f2b7 4351 struct block *block)
14f9c5c9
AS
4352{
4353 int i;
4c4b4cd2 4354 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4355
529cad9c
PH
4356 /* Do not try to complete stub types, as the debugger is probably
4357 already scanning all symbols matching a certain name at the
4358 time when this function is called. Trying to replace the stub
4359 type by its associated full type will cause us to restart a scan
4360 which may lead to an infinite recursion. Instead, the client
4361 collecting the matching symbols will end up collecting several
4362 matches, with at least one of them complete. It can then filter
4363 out the stub ones if needed. */
4364
4c4b4cd2
PH
4365 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4366 {
4367 if (lesseq_defined_than (sym, prevDefns[i].sym))
4368 return;
4369 else if (lesseq_defined_than (prevDefns[i].sym, sym))
4370 {
4371 prevDefns[i].sym = sym;
4372 prevDefns[i].block = block;
4c4b4cd2 4373 return;
76a01679 4374 }
4c4b4cd2
PH
4375 }
4376
4377 {
4378 struct ada_symbol_info info;
4379
4380 info.sym = sym;
4381 info.block = block;
4c4b4cd2
PH
4382 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
4383 }
4384}
4385
4386/* Number of ada_symbol_info structures currently collected in
4387 current vector in *OBSTACKP. */
4388
76a01679
JB
4389static int
4390num_defns_collected (struct obstack *obstackp)
4c4b4cd2
PH
4391{
4392 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
4393}
4394
4395/* Vector of ada_symbol_info structures currently collected in current
4396 vector in *OBSTACKP. If FINISH, close off the vector and return
4397 its final address. */
4398
76a01679 4399static struct ada_symbol_info *
4c4b4cd2
PH
4400defns_collected (struct obstack *obstackp, int finish)
4401{
4402 if (finish)
4403 return obstack_finish (obstackp);
4404 else
4405 return (struct ada_symbol_info *) obstack_base (obstackp);
4406}
4407
7c7b6655
TT
4408/* Return a bound minimal symbol matching NAME according to Ada
4409 decoding rules. Returns an invalid symbol if there is no such
4410 minimal symbol. Names prefixed with "standard__" are handled
4411 specially: "standard__" is first stripped off, and only static and
4412 global symbols are searched. */
4c4b4cd2 4413
7c7b6655 4414struct bound_minimal_symbol
96d887e8 4415ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4416{
7c7b6655 4417 struct bound_minimal_symbol result;
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
7c7b6655
TT
4422 memset (&result, 0, sizeof (result));
4423
c0431670
JB
4424 /* Special case: If the user specifies a symbol name inside package
4425 Standard, do a non-wild matching of the symbol name without
4426 the "standard__" prefix. This was primarily introduced in order
4427 to allow the user to specifically access the standard exceptions
4428 using, for instance, Standard.Constraint_Error when Constraint_Error
4429 is ambiguous (due to the user defining its own Constraint_Error
4430 entity inside its program). */
96d887e8 4431 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
c0431670 4432 name += sizeof ("standard__") - 1;
4c4b4cd2 4433
96d887e8
PH
4434 ALL_MSYMBOLS (objfile, msymbol)
4435 {
dc4024cd 4436 if (match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match_p)
96d887e8 4437 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
7c7b6655
TT
4438 {
4439 result.minsym = msymbol;
4440 result.objfile = objfile;
4441 break;
4442 }
96d887e8 4443 }
4c4b4cd2 4444
7c7b6655 4445 return result;
96d887e8 4446}
4c4b4cd2 4447
96d887e8
PH
4448/* For all subprograms that statically enclose the subprogram of the
4449 selected frame, add symbols matching identifier NAME in DOMAIN
4450 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4451 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4452 with a wildcard prefix. */
4c4b4cd2 4453
96d887e8
PH
4454static void
4455add_symbols_from_enclosing_procs (struct obstack *obstackp,
76a01679 4456 const char *name, domain_enum namespace,
48b78332 4457 int wild_match_p)
96d887e8 4458{
96d887e8 4459}
14f9c5c9 4460
96d887e8
PH
4461/* True if TYPE is definitely an artificial type supplied to a symbol
4462 for which no debugging information was given in the symbol file. */
14f9c5c9 4463
96d887e8
PH
4464static int
4465is_nondebugging_type (struct type *type)
4466{
0d5cff50 4467 const char *name = ada_type_name (type);
5b4ee69b 4468
96d887e8
PH
4469 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4470}
4c4b4cd2 4471
8f17729f
JB
4472/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4473 that are deemed "identical" for practical purposes.
4474
4475 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4476 types and that their number of enumerals is identical (in other
4477 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4478
4479static int
4480ada_identical_enum_types_p (struct type *type1, struct type *type2)
4481{
4482 int i;
4483
4484 /* The heuristic we use here is fairly conservative. We consider
4485 that 2 enumerate types are identical if they have the same
4486 number of enumerals and that all enumerals have the same
4487 underlying value and name. */
4488
4489 /* All enums in the type should have an identical underlying value. */
4490 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 4491 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
4492 return 0;
4493
4494 /* All enumerals should also have the same name (modulo any numerical
4495 suffix). */
4496 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4497 {
0d5cff50
DE
4498 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4499 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
4500 int len_1 = strlen (name_1);
4501 int len_2 = strlen (name_2);
4502
4503 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4504 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4505 if (len_1 != len_2
4506 || strncmp (TYPE_FIELD_NAME (type1, i),
4507 TYPE_FIELD_NAME (type2, i),
4508 len_1) != 0)
4509 return 0;
4510 }
4511
4512 return 1;
4513}
4514
4515/* Return nonzero if all the symbols in SYMS are all enumeral symbols
4516 that are deemed "identical" for practical purposes. Sometimes,
4517 enumerals are not strictly identical, but their types are so similar
4518 that they can be considered identical.
4519
4520 For instance, consider the following code:
4521
4522 type Color is (Black, Red, Green, Blue, White);
4523 type RGB_Color is new Color range Red .. Blue;
4524
4525 Type RGB_Color is a subrange of an implicit type which is a copy
4526 of type Color. If we call that implicit type RGB_ColorB ("B" is
4527 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4528 As a result, when an expression references any of the enumeral
4529 by name (Eg. "print green"), the expression is technically
4530 ambiguous and the user should be asked to disambiguate. But
4531 doing so would only hinder the user, since it wouldn't matter
4532 what choice he makes, the outcome would always be the same.
4533 So, for practical purposes, we consider them as the same. */
4534
4535static int
4536symbols_are_identical_enums (struct ada_symbol_info *syms, int nsyms)
4537{
4538 int i;
4539
4540 /* Before performing a thorough comparison check of each type,
4541 we perform a series of inexpensive checks. We expect that these
4542 checks will quickly fail in the vast majority of cases, and thus
4543 help prevent the unnecessary use of a more expensive comparison.
4544 Said comparison also expects us to make some of these checks
4545 (see ada_identical_enum_types_p). */
4546
4547 /* Quick check: All symbols should have an enum type. */
4548 for (i = 0; i < nsyms; i++)
4549 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM)
4550 return 0;
4551
4552 /* Quick check: They should all have the same value. */
4553 for (i = 1; i < nsyms; i++)
4554 if (SYMBOL_VALUE (syms[i].sym) != SYMBOL_VALUE (syms[0].sym))
4555 return 0;
4556
4557 /* Quick check: They should all have the same number of enumerals. */
4558 for (i = 1; i < nsyms; i++)
4559 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].sym))
4560 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].sym)))
4561 return 0;
4562
4563 /* All the sanity checks passed, so we might have a set of
4564 identical enumeration types. Perform a more complete
4565 comparison of the type of each symbol. */
4566 for (i = 1; i < nsyms; i++)
4567 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].sym),
4568 SYMBOL_TYPE (syms[0].sym)))
4569 return 0;
4570
4571 return 1;
4572}
4573
96d887e8
PH
4574/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4575 duplicate other symbols in the list (The only case I know of where
4576 this happens is when object files containing stabs-in-ecoff are
4577 linked with files containing ordinary ecoff debugging symbols (or no
4578 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4579 Returns the number of items in the modified list. */
4c4b4cd2 4580
96d887e8
PH
4581static int
4582remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4583{
4584 int i, j;
4c4b4cd2 4585
8f17729f
JB
4586 /* We should never be called with less than 2 symbols, as there
4587 cannot be any extra symbol in that case. But it's easy to
4588 handle, since we have nothing to do in that case. */
4589 if (nsyms < 2)
4590 return nsyms;
4591
96d887e8
PH
4592 i = 0;
4593 while (i < nsyms)
4594 {
a35ddb44 4595 int remove_p = 0;
339c13b6
JB
4596
4597 /* If two symbols have the same name and one of them is a stub type,
4598 the get rid of the stub. */
4599
4600 if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym))
4601 && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL)
4602 {
4603 for (j = 0; j < nsyms; j++)
4604 {
4605 if (j != i
4606 && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym))
4607 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4608 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4609 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0)
a35ddb44 4610 remove_p = 1;
339c13b6
JB
4611 }
4612 }
4613
4614 /* Two symbols with the same name, same class and same address
4615 should be identical. */
4616
4617 else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
96d887e8
PH
4618 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4619 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4620 {
4621 for (j = 0; j < nsyms; j += 1)
4622 {
4623 if (i != j
4624 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4625 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
76a01679 4626 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
96d887e8
PH
4627 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4628 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4629 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
a35ddb44 4630 remove_p = 1;
4c4b4cd2 4631 }
4c4b4cd2 4632 }
339c13b6 4633
a35ddb44 4634 if (remove_p)
339c13b6
JB
4635 {
4636 for (j = i + 1; j < nsyms; j += 1)
4637 syms[j - 1] = syms[j];
4638 nsyms -= 1;
4639 }
4640
96d887e8 4641 i += 1;
14f9c5c9 4642 }
8f17729f
JB
4643
4644 /* If all the remaining symbols are identical enumerals, then
4645 just keep the first one and discard the rest.
4646
4647 Unlike what we did previously, we do not discard any entry
4648 unless they are ALL identical. This is because the symbol
4649 comparison is not a strict comparison, but rather a practical
4650 comparison. If all symbols are considered identical, then
4651 we can just go ahead and use the first one and discard the rest.
4652 But if we cannot reduce the list to a single element, we have
4653 to ask the user to disambiguate anyways. And if we have to
4654 present a multiple-choice menu, it's less confusing if the list
4655 isn't missing some choices that were identical and yet distinct. */
4656 if (symbols_are_identical_enums (syms, nsyms))
4657 nsyms = 1;
4658
96d887e8 4659 return nsyms;
14f9c5c9
AS
4660}
4661
96d887e8
PH
4662/* Given a type that corresponds to a renaming entity, use the type name
4663 to extract the scope (package name or function name, fully qualified,
4664 and following the GNAT encoding convention) where this renaming has been
4665 defined. The string returned needs to be deallocated after use. */
4c4b4cd2 4666
96d887e8
PH
4667static char *
4668xget_renaming_scope (struct type *renaming_type)
14f9c5c9 4669{
96d887e8 4670 /* The renaming types adhere to the following convention:
0963b4bd 4671 <scope>__<rename>___<XR extension>.
96d887e8
PH
4672 So, to extract the scope, we search for the "___XR" extension,
4673 and then backtrack until we find the first "__". */
76a01679 4674
96d887e8
PH
4675 const char *name = type_name_no_tag (renaming_type);
4676 char *suffix = strstr (name, "___XR");
4677 char *last;
4678 int scope_len;
4679 char *scope;
14f9c5c9 4680
96d887e8
PH
4681 /* Now, backtrack a bit until we find the first "__". Start looking
4682 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 4683
96d887e8
PH
4684 for (last = suffix - 3; last > name; last--)
4685 if (last[0] == '_' && last[1] == '_')
4686 break;
76a01679 4687
96d887e8 4688 /* Make a copy of scope and return it. */
14f9c5c9 4689
96d887e8
PH
4690 scope_len = last - name;
4691 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
14f9c5c9 4692
96d887e8
PH
4693 strncpy (scope, name, scope_len);
4694 scope[scope_len] = '\0';
4c4b4cd2 4695
96d887e8 4696 return scope;
4c4b4cd2
PH
4697}
4698
96d887e8 4699/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 4700
96d887e8
PH
4701static int
4702is_package_name (const char *name)
4c4b4cd2 4703{
96d887e8
PH
4704 /* Here, We take advantage of the fact that no symbols are generated
4705 for packages, while symbols are generated for each function.
4706 So the condition for NAME represent a package becomes equivalent
4707 to NAME not existing in our list of symbols. There is only one
4708 small complication with library-level functions (see below). */
4c4b4cd2 4709
96d887e8 4710 char *fun_name;
76a01679 4711
96d887e8
PH
4712 /* If it is a function that has not been defined at library level,
4713 then we should be able to look it up in the symbols. */
4714 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4715 return 0;
14f9c5c9 4716
96d887e8
PH
4717 /* Library-level function names start with "_ada_". See if function
4718 "_ada_" followed by NAME can be found. */
14f9c5c9 4719
96d887e8 4720 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 4721 functions names cannot contain "__" in them. */
96d887e8
PH
4722 if (strstr (name, "__") != NULL)
4723 return 0;
4c4b4cd2 4724
b435e160 4725 fun_name = xstrprintf ("_ada_%s", name);
14f9c5c9 4726
96d887e8
PH
4727 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4728}
14f9c5c9 4729
96d887e8 4730/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 4731 not visible from FUNCTION_NAME. */
14f9c5c9 4732
96d887e8 4733static int
0d5cff50 4734old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 4735{
aeb5907d 4736 char *scope;
1509e573 4737 struct cleanup *old_chain;
aeb5907d
JB
4738
4739 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4740 return 0;
4741
4742 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
1509e573 4743 old_chain = make_cleanup (xfree, scope);
14f9c5c9 4744
96d887e8
PH
4745 /* If the rename has been defined in a package, then it is visible. */
4746 if (is_package_name (scope))
1509e573
JB
4747 {
4748 do_cleanups (old_chain);
4749 return 0;
4750 }
14f9c5c9 4751
96d887e8
PH
4752 /* Check that the rename is in the current function scope by checking
4753 that its name starts with SCOPE. */
76a01679 4754
96d887e8
PH
4755 /* If the function name starts with "_ada_", it means that it is
4756 a library-level function. Strip this prefix before doing the
4757 comparison, as the encoding for the renaming does not contain
4758 this prefix. */
4759 if (strncmp (function_name, "_ada_", 5) == 0)
4760 function_name += 5;
f26caa11 4761
1509e573
JB
4762 {
4763 int is_invisible = strncmp (function_name, scope, strlen (scope)) != 0;
4764
4765 do_cleanups (old_chain);
4766 return is_invisible;
4767 }
f26caa11
PH
4768}
4769
aeb5907d
JB
4770/* Remove entries from SYMS that corresponds to a renaming entity that
4771 is not visible from the function associated with CURRENT_BLOCK or
4772 that is superfluous due to the presence of more specific renaming
4773 information. Places surviving symbols in the initial entries of
4774 SYMS and returns the number of surviving symbols.
96d887e8
PH
4775
4776 Rationale:
aeb5907d
JB
4777 First, in cases where an object renaming is implemented as a
4778 reference variable, GNAT may produce both the actual reference
4779 variable and the renaming encoding. In this case, we discard the
4780 latter.
4781
4782 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
4783 entity. Unfortunately, STABS currently does not support the definition
4784 of types that are local to a given lexical block, so all renamings types
4785 are emitted at library level. As a consequence, if an application
4786 contains two renaming entities using the same name, and a user tries to
4787 print the value of one of these entities, the result of the ada symbol
4788 lookup will also contain the wrong renaming type.
f26caa11 4789
96d887e8
PH
4790 This function partially covers for this limitation by attempting to
4791 remove from the SYMS list renaming symbols that should be visible
4792 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4793 method with the current information available. The implementation
4794 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4795
4796 - When the user tries to print a rename in a function while there
4797 is another rename entity defined in a package: Normally, the
4798 rename in the function has precedence over the rename in the
4799 package, so the latter should be removed from the list. This is
4800 currently not the case.
4801
4802 - This function will incorrectly remove valid renames if
4803 the CURRENT_BLOCK corresponds to a function which symbol name
4804 has been changed by an "Export" pragma. As a consequence,
4805 the user will be unable to print such rename entities. */
4c4b4cd2 4806
14f9c5c9 4807static int
aeb5907d
JB
4808remove_irrelevant_renamings (struct ada_symbol_info *syms,
4809 int nsyms, const struct block *current_block)
4c4b4cd2
PH
4810{
4811 struct symbol *current_function;
0d5cff50 4812 const char *current_function_name;
4c4b4cd2 4813 int i;
aeb5907d
JB
4814 int is_new_style_renaming;
4815
4816 /* If there is both a renaming foo___XR... encoded as a variable and
4817 a simple variable foo in the same block, discard the latter.
0963b4bd 4818 First, zero out such symbols, then compress. */
aeb5907d
JB
4819 is_new_style_renaming = 0;
4820 for (i = 0; i < nsyms; i += 1)
4821 {
4822 struct symbol *sym = syms[i].sym;
270140bd 4823 const struct block *block = syms[i].block;
aeb5907d
JB
4824 const char *name;
4825 const char *suffix;
4826
4827 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4828 continue;
4829 name = SYMBOL_LINKAGE_NAME (sym);
4830 suffix = strstr (name, "___XR");
4831
4832 if (suffix != NULL)
4833 {
4834 int name_len = suffix - name;
4835 int j;
5b4ee69b 4836
aeb5907d
JB
4837 is_new_style_renaming = 1;
4838 for (j = 0; j < nsyms; j += 1)
4839 if (i != j && syms[j].sym != NULL
4840 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
4841 name_len) == 0
4842 && block == syms[j].block)
4843 syms[j].sym = NULL;
4844 }
4845 }
4846 if (is_new_style_renaming)
4847 {
4848 int j, k;
4849
4850 for (j = k = 0; j < nsyms; j += 1)
4851 if (syms[j].sym != NULL)
4852 {
4853 syms[k] = syms[j];
4854 k += 1;
4855 }
4856 return k;
4857 }
4c4b4cd2
PH
4858
4859 /* Extract the function name associated to CURRENT_BLOCK.
4860 Abort if unable to do so. */
76a01679 4861
4c4b4cd2
PH
4862 if (current_block == NULL)
4863 return nsyms;
76a01679 4864
7f0df278 4865 current_function = block_linkage_function (current_block);
4c4b4cd2
PH
4866 if (current_function == NULL)
4867 return nsyms;
4868
4869 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
4870 if (current_function_name == NULL)
4871 return nsyms;
4872
4873 /* Check each of the symbols, and remove it from the list if it is
4874 a type corresponding to a renaming that is out of the scope of
4875 the current block. */
4876
4877 i = 0;
4878 while (i < nsyms)
4879 {
aeb5907d
JB
4880 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
4881 == ADA_OBJECT_RENAMING
4882 && old_renaming_is_invisible (syms[i].sym, current_function_name))
4c4b4cd2
PH
4883 {
4884 int j;
5b4ee69b 4885
aeb5907d 4886 for (j = i + 1; j < nsyms; j += 1)
76a01679 4887 syms[j - 1] = syms[j];
4c4b4cd2
PH
4888 nsyms -= 1;
4889 }
4890 else
4891 i += 1;
4892 }
4893
4894 return nsyms;
4895}
4896
339c13b6
JB
4897/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4898 whose name and domain match NAME and DOMAIN respectively.
4899 If no match was found, then extend the search to "enclosing"
4900 routines (in other words, if we're inside a nested function,
4901 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
4902 If WILD_MATCH_P is nonzero, perform the naming matching in
4903 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
4904
4905 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4906
4907static void
4908ada_add_local_symbols (struct obstack *obstackp, const char *name,
4909 struct block *block, domain_enum domain,
d0a8ab18 4910 int wild_match_p)
339c13b6
JB
4911{
4912 int block_depth = 0;
4913
4914 while (block != NULL)
4915 {
4916 block_depth += 1;
d0a8ab18
JB
4917 ada_add_block_symbols (obstackp, block, name, domain, NULL,
4918 wild_match_p);
339c13b6
JB
4919
4920 /* If we found a non-function match, assume that's the one. */
4921 if (is_nonfunction (defns_collected (obstackp, 0),
4922 num_defns_collected (obstackp)))
4923 return;
4924
4925 block = BLOCK_SUPERBLOCK (block);
4926 }
4927
4928 /* If no luck so far, try to find NAME as a local symbol in some lexically
4929 enclosing subprogram. */
4930 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
d0a8ab18 4931 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match_p);
339c13b6
JB
4932}
4933
ccefe4c4 4934/* An object of this type is used as the user_data argument when
40658b94 4935 calling the map_matching_symbols method. */
ccefe4c4 4936
40658b94 4937struct match_data
ccefe4c4 4938{
40658b94 4939 struct objfile *objfile;
ccefe4c4 4940 struct obstack *obstackp;
40658b94
PH
4941 struct symbol *arg_sym;
4942 int found_sym;
ccefe4c4
TT
4943};
4944
40658b94
PH
4945/* A callback for add_matching_symbols that adds SYM, found in BLOCK,
4946 to a list of symbols. DATA0 is a pointer to a struct match_data *
4947 containing the obstack that collects the symbol list, the file that SYM
4948 must come from, a flag indicating whether a non-argument symbol has
4949 been found in the current block, and the last argument symbol
4950 passed in SYM within the current block (if any). When SYM is null,
4951 marking the end of a block, the argument symbol is added if no
4952 other has been found. */
ccefe4c4 4953
40658b94
PH
4954static int
4955aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 4956{
40658b94
PH
4957 struct match_data *data = (struct match_data *) data0;
4958
4959 if (sym == NULL)
4960 {
4961 if (!data->found_sym && data->arg_sym != NULL)
4962 add_defn_to_vec (data->obstackp,
4963 fixup_symbol_section (data->arg_sym, data->objfile),
4964 block);
4965 data->found_sym = 0;
4966 data->arg_sym = NULL;
4967 }
4968 else
4969 {
4970 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
4971 return 0;
4972 else if (SYMBOL_IS_ARGUMENT (sym))
4973 data->arg_sym = sym;
4974 else
4975 {
4976 data->found_sym = 1;
4977 add_defn_to_vec (data->obstackp,
4978 fixup_symbol_section (sym, data->objfile),
4979 block);
4980 }
4981 }
4982 return 0;
4983}
4984
db230ce3
JB
4985/* Implements compare_names, but only applying the comparision using
4986 the given CASING. */
5b4ee69b 4987
40658b94 4988static int
db230ce3
JB
4989compare_names_with_case (const char *string1, const char *string2,
4990 enum case_sensitivity casing)
40658b94
PH
4991{
4992 while (*string1 != '\0' && *string2 != '\0')
4993 {
db230ce3
JB
4994 char c1, c2;
4995
40658b94
PH
4996 if (isspace (*string1) || isspace (*string2))
4997 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
4998
4999 if (casing == case_sensitive_off)
5000 {
5001 c1 = tolower (*string1);
5002 c2 = tolower (*string2);
5003 }
5004 else
5005 {
5006 c1 = *string1;
5007 c2 = *string2;
5008 }
5009 if (c1 != c2)
40658b94 5010 break;
db230ce3 5011
40658b94
PH
5012 string1 += 1;
5013 string2 += 1;
5014 }
db230ce3 5015
40658b94
PH
5016 switch (*string1)
5017 {
5018 case '(':
5019 return strcmp_iw_ordered (string1, string2);
5020 case '_':
5021 if (*string2 == '\0')
5022 {
052874e8 5023 if (is_name_suffix (string1))
40658b94
PH
5024 return 0;
5025 else
1a1d5513 5026 return 1;
40658b94 5027 }
dbb8534f 5028 /* FALLTHROUGH */
40658b94
PH
5029 default:
5030 if (*string2 == '(')
5031 return strcmp_iw_ordered (string1, string2);
5032 else
db230ce3
JB
5033 {
5034 if (casing == case_sensitive_off)
5035 return tolower (*string1) - tolower (*string2);
5036 else
5037 return *string1 - *string2;
5038 }
40658b94 5039 }
ccefe4c4
TT
5040}
5041
db230ce3
JB
5042/* Compare STRING1 to STRING2, with results as for strcmp.
5043 Compatible with strcmp_iw_ordered in that...
5044
5045 strcmp_iw_ordered (STRING1, STRING2) <= 0
5046
5047 ... implies...
5048
5049 compare_names (STRING1, STRING2) <= 0
5050
5051 (they may differ as to what symbols compare equal). */
5052
5053static int
5054compare_names (const char *string1, const char *string2)
5055{
5056 int result;
5057
5058 /* Similar to what strcmp_iw_ordered does, we need to perform
5059 a case-insensitive comparison first, and only resort to
5060 a second, case-sensitive, comparison if the first one was
5061 not sufficient to differentiate the two strings. */
5062
5063 result = compare_names_with_case (string1, string2, case_sensitive_off);
5064 if (result == 0)
5065 result = compare_names_with_case (string1, string2, case_sensitive_on);
5066
5067 return result;
5068}
5069
339c13b6
JB
5070/* Add to OBSTACKP all non-local symbols whose name and domain match
5071 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
5072 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
5073
5074static void
40658b94
PH
5075add_nonlocal_symbols (struct obstack *obstackp, const char *name,
5076 domain_enum domain, int global,
5077 int is_wild_match)
339c13b6
JB
5078{
5079 struct objfile *objfile;
40658b94 5080 struct match_data data;
339c13b6 5081
6475f2fe 5082 memset (&data, 0, sizeof data);
ccefe4c4 5083 data.obstackp = obstackp;
339c13b6 5084
ccefe4c4 5085 ALL_OBJFILES (objfile)
40658b94
PH
5086 {
5087 data.objfile = objfile;
5088
5089 if (is_wild_match)
ade7ed9e 5090 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
40658b94
PH
5091 aux_add_nonlocal_symbols, &data,
5092 wild_match, NULL);
5093 else
ade7ed9e 5094 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
40658b94
PH
5095 aux_add_nonlocal_symbols, &data,
5096 full_match, compare_names);
5097 }
5098
5099 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5100 {
5101 ALL_OBJFILES (objfile)
5102 {
5103 char *name1 = alloca (strlen (name) + sizeof ("_ada_"));
5104 strcpy (name1, "_ada_");
5105 strcpy (name1 + sizeof ("_ada_") - 1, name);
5106 data.objfile = objfile;
ade7ed9e
DE
5107 objfile->sf->qf->map_matching_symbols (objfile, name1, domain,
5108 global,
0963b4bd
MS
5109 aux_add_nonlocal_symbols,
5110 &data,
40658b94
PH
5111 full_match, compare_names);
5112 }
5113 }
339c13b6
JB
5114}
5115
4eeaa230
DE
5116/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and, if full_search is
5117 non-zero, enclosing scope and in global scopes, returning the number of
5118 matches.
9f88c959 5119 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4c4b4cd2 5120 indicating the symbols found and the blocks and symbol tables (if
4eeaa230
DE
5121 any) in which they were found. This vector is transient---good only to
5122 the next call of ada_lookup_symbol_list.
5123
5124 When full_search is non-zero, any non-function/non-enumeral
4c4b4cd2
PH
5125 symbol match within the nest of blocks whose innermost member is BLOCK0,
5126 is the one match returned (no other matches in that or
d9680e73 5127 enclosing blocks is returned). If there are any matches in or
4eeaa230
DE
5128 surrounding BLOCK0, then these alone are returned.
5129
9f88c959 5130 Names prefixed with "standard__" are handled specially: "standard__"
4c4b4cd2 5131 is first stripped off, and only static and global symbols are searched. */
14f9c5c9 5132
4eeaa230
DE
5133static int
5134ada_lookup_symbol_list_worker (const char *name0, const struct block *block0,
5135 domain_enum namespace,
5136 struct ada_symbol_info **results,
5137 int full_search)
14f9c5c9
AS
5138{
5139 struct symbol *sym;
14f9c5c9 5140 struct block *block;
4c4b4cd2 5141 const char *name;
82ccd55e 5142 const int wild_match_p = should_use_wild_match (name0);
14f9c5c9 5143 int cacheIfUnique;
4c4b4cd2 5144 int ndefns;
14f9c5c9 5145
4c4b4cd2
PH
5146 obstack_free (&symbol_list_obstack, NULL);
5147 obstack_init (&symbol_list_obstack);
14f9c5c9 5148
14f9c5c9
AS
5149 cacheIfUnique = 0;
5150
5151 /* Search specified block and its superiors. */
5152
4c4b4cd2 5153 name = name0;
76a01679
JB
5154 block = (struct block *) block0; /* FIXME: No cast ought to be
5155 needed, but adding const will
5156 have a cascade effect. */
339c13b6
JB
5157
5158 /* Special case: If the user specifies a symbol name inside package
5159 Standard, do a non-wild matching of the symbol name without
5160 the "standard__" prefix. This was primarily introduced in order
5161 to allow the user to specifically access the standard exceptions
5162 using, for instance, Standard.Constraint_Error when Constraint_Error
5163 is ambiguous (due to the user defining its own Constraint_Error
5164 entity inside its program). */
4c4b4cd2
PH
5165 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
5166 {
4c4b4cd2
PH
5167 block = NULL;
5168 name = name0 + sizeof ("standard__") - 1;
5169 }
5170
339c13b6 5171 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5172
4eeaa230
DE
5173 if (block != NULL)
5174 {
5175 if (full_search)
5176 {
5177 ada_add_local_symbols (&symbol_list_obstack, name, block,
5178 namespace, wild_match_p);
5179 }
5180 else
5181 {
5182 /* In the !full_search case we're are being called by
5183 ada_iterate_over_symbols, and we don't want to search
5184 superblocks. */
5185 ada_add_block_symbols (&symbol_list_obstack, block, name,
5186 namespace, NULL, wild_match_p);
5187 }
5188 if (num_defns_collected (&symbol_list_obstack) > 0 || !full_search)
5189 goto done;
5190 }
d2e4a39e 5191
339c13b6
JB
5192 /* No non-global symbols found. Check our cache to see if we have
5193 already performed this search before. If we have, then return
5194 the same result. */
5195
14f9c5c9 5196 cacheIfUnique = 1;
2570f2b7 5197 if (lookup_cached_symbol (name0, namespace, &sym, &block))
4c4b4cd2
PH
5198 {
5199 if (sym != NULL)
2570f2b7 5200 add_defn_to_vec (&symbol_list_obstack, sym, block);
4c4b4cd2
PH
5201 goto done;
5202 }
14f9c5c9 5203
339c13b6
JB
5204 /* Search symbols from all global blocks. */
5205
40658b94 5206 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 1,
82ccd55e 5207 wild_match_p);
d2e4a39e 5208
4c4b4cd2 5209 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5210 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5211
4c4b4cd2 5212 if (num_defns_collected (&symbol_list_obstack) == 0)
40658b94 5213 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 0,
82ccd55e 5214 wild_match_p);
14f9c5c9 5215
4c4b4cd2
PH
5216done:
5217 ndefns = num_defns_collected (&symbol_list_obstack);
5218 *results = defns_collected (&symbol_list_obstack, 1);
5219
5220 ndefns = remove_extra_symbols (*results, ndefns);
5221
2ad01556 5222 if (ndefns == 0 && full_search)
2570f2b7 5223 cache_symbol (name0, namespace, NULL, NULL);
14f9c5c9 5224
2ad01556 5225 if (ndefns == 1 && full_search && cacheIfUnique)
2570f2b7 5226 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
14f9c5c9 5227
aeb5907d 5228 ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
14f9c5c9 5229
14f9c5c9
AS
5230 return ndefns;
5231}
5232
4eeaa230
DE
5233/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and
5234 in global scopes, returning the number of matches, and setting *RESULTS
5235 to a vector of (SYM,BLOCK) tuples.
5236 See ada_lookup_symbol_list_worker for further details. */
5237
5238int
5239ada_lookup_symbol_list (const char *name0, const struct block *block0,
5240 domain_enum domain, struct ada_symbol_info **results)
5241{
5242 return ada_lookup_symbol_list_worker (name0, block0, domain, results, 1);
5243}
5244
5245/* Implementation of the la_iterate_over_symbols method. */
5246
5247static void
5248ada_iterate_over_symbols (const struct block *block,
5249 const char *name, domain_enum domain,
5250 symbol_found_callback_ftype *callback,
5251 void *data)
5252{
5253 int ndefs, i;
5254 struct ada_symbol_info *results;
5255
5256 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5257 for (i = 0; i < ndefs; ++i)
5258 {
5259 if (! (*callback) (results[i].sym, data))
5260 break;
5261 }
5262}
5263
f8eba3c6
TT
5264/* If NAME is the name of an entity, return a string that should
5265 be used to look that entity up in Ada units. This string should
5266 be deallocated after use using xfree.
5267
5268 NAME can have any form that the "break" or "print" commands might
5269 recognize. In other words, it does not have to be the "natural"
5270 name, or the "encoded" name. */
5271
5272char *
5273ada_name_for_lookup (const char *name)
5274{
5275 char *canon;
5276 int nlen = strlen (name);
5277
5278 if (name[0] == '<' && name[nlen - 1] == '>')
5279 {
5280 canon = xmalloc (nlen - 1);
5281 memcpy (canon, name + 1, nlen - 2);
5282 canon[nlen - 2] = '\0';
5283 }
5284 else
5285 canon = xstrdup (ada_encode (ada_fold_name (name)));
5286 return canon;
5287}
5288
4e5c77fe
JB
5289/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5290 to 1, but choosing the first symbol found if there are multiple
5291 choices.
5292
5e2336be
JB
5293 The result is stored in *INFO, which must be non-NULL.
5294 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5295
5296void
5297ada_lookup_encoded_symbol (const char *name, const struct block *block,
5298 domain_enum namespace,
5e2336be 5299 struct ada_symbol_info *info)
14f9c5c9 5300{
4c4b4cd2 5301 struct ada_symbol_info *candidates;
14f9c5c9
AS
5302 int n_candidates;
5303
5e2336be
JB
5304 gdb_assert (info != NULL);
5305 memset (info, 0, sizeof (struct ada_symbol_info));
4e5c77fe 5306
4eeaa230 5307 n_candidates = ada_lookup_symbol_list (name, block, namespace, &candidates);
14f9c5c9 5308 if (n_candidates == 0)
4e5c77fe 5309 return;
4c4b4cd2 5310
5e2336be
JB
5311 *info = candidates[0];
5312 info->sym = fixup_symbol_section (info->sym, NULL);
4e5c77fe 5313}
aeb5907d
JB
5314
5315/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5316 scope and in global scopes, or NULL if none. NAME is folded and
5317 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5318 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5319 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5320
aeb5907d
JB
5321struct symbol *
5322ada_lookup_symbol (const char *name, const struct block *block0,
21b556f4 5323 domain_enum namespace, int *is_a_field_of_this)
aeb5907d 5324{
5e2336be 5325 struct ada_symbol_info info;
4e5c77fe 5326
aeb5907d
JB
5327 if (is_a_field_of_this != NULL)
5328 *is_a_field_of_this = 0;
5329
4e5c77fe 5330 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
5e2336be
JB
5331 block0, namespace, &info);
5332 return info.sym;
4c4b4cd2 5333}
14f9c5c9 5334
4c4b4cd2
PH
5335static struct symbol *
5336ada_lookup_symbol_nonlocal (const char *name,
76a01679 5337 const struct block *block,
21b556f4 5338 const domain_enum domain)
4c4b4cd2 5339{
94af9270 5340 return ada_lookup_symbol (name, block_static_block (block), domain, NULL);
14f9c5c9
AS
5341}
5342
5343
4c4b4cd2
PH
5344/* True iff STR is a possible encoded suffix of a normal Ada name
5345 that is to be ignored for matching purposes. Suffixes of parallel
5346 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5347 are given by any of the regular expressions:
4c4b4cd2 5348
babe1480
JB
5349 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5350 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5351 TKB [subprogram suffix for task bodies]
babe1480 5352 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5353 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5354
5355 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5356 match is performed. This sequence is used to differentiate homonyms,
5357 is an optional part of a valid name suffix. */
4c4b4cd2 5358
14f9c5c9 5359static int
d2e4a39e 5360is_name_suffix (const char *str)
14f9c5c9
AS
5361{
5362 int k;
4c4b4cd2
PH
5363 const char *matching;
5364 const int len = strlen (str);
5365
babe1480
JB
5366 /* Skip optional leading __[0-9]+. */
5367
4c4b4cd2
PH
5368 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5369 {
babe1480
JB
5370 str += 3;
5371 while (isdigit (str[0]))
5372 str += 1;
4c4b4cd2 5373 }
babe1480
JB
5374
5375 /* [.$][0-9]+ */
4c4b4cd2 5376
babe1480 5377 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5378 {
babe1480 5379 matching = str + 1;
4c4b4cd2
PH
5380 while (isdigit (matching[0]))
5381 matching += 1;
5382 if (matching[0] == '\0')
5383 return 1;
5384 }
5385
5386 /* ___[0-9]+ */
babe1480 5387
4c4b4cd2
PH
5388 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5389 {
5390 matching = str + 3;
5391 while (isdigit (matching[0]))
5392 matching += 1;
5393 if (matching[0] == '\0')
5394 return 1;
5395 }
5396
9ac7f98e
JB
5397 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5398
5399 if (strcmp (str, "TKB") == 0)
5400 return 1;
5401
529cad9c
PH
5402#if 0
5403 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
5404 with a N at the end. Unfortunately, the compiler uses the same
5405 convention for other internal types it creates. So treating
529cad9c 5406 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
5407 some regressions. For instance, consider the case of an enumerated
5408 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
5409 name ends with N.
5410 Having a single character like this as a suffix carrying some
0963b4bd 5411 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
5412 to be something like "_N" instead. In the meantime, do not do
5413 the following check. */
5414 /* Protected Object Subprograms */
5415 if (len == 1 && str [0] == 'N')
5416 return 1;
5417#endif
5418
5419 /* _E[0-9]+[bs]$ */
5420 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5421 {
5422 matching = str + 3;
5423 while (isdigit (matching[0]))
5424 matching += 1;
5425 if ((matching[0] == 'b' || matching[0] == 's')
5426 && matching [1] == '\0')
5427 return 1;
5428 }
5429
4c4b4cd2
PH
5430 /* ??? We should not modify STR directly, as we are doing below. This
5431 is fine in this case, but may become problematic later if we find
5432 that this alternative did not work, and want to try matching
5433 another one from the begining of STR. Since we modified it, we
5434 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
5435 if (str[0] == 'X')
5436 {
5437 str += 1;
d2e4a39e 5438 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
5439 {
5440 if (str[0] != 'n' && str[0] != 'b')
5441 return 0;
5442 str += 1;
5443 }
14f9c5c9 5444 }
babe1480 5445
14f9c5c9
AS
5446 if (str[0] == '\000')
5447 return 1;
babe1480 5448
d2e4a39e 5449 if (str[0] == '_')
14f9c5c9
AS
5450 {
5451 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 5452 return 0;
d2e4a39e 5453 if (str[2] == '_')
4c4b4cd2 5454 {
61ee279c
PH
5455 if (strcmp (str + 3, "JM") == 0)
5456 return 1;
5457 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5458 the LJM suffix in favor of the JM one. But we will
5459 still accept LJM as a valid suffix for a reasonable
5460 amount of time, just to allow ourselves to debug programs
5461 compiled using an older version of GNAT. */
4c4b4cd2
PH
5462 if (strcmp (str + 3, "LJM") == 0)
5463 return 1;
5464 if (str[3] != 'X')
5465 return 0;
1265e4aa
JB
5466 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5467 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
5468 return 1;
5469 if (str[4] == 'R' && str[5] != 'T')
5470 return 1;
5471 return 0;
5472 }
5473 if (!isdigit (str[2]))
5474 return 0;
5475 for (k = 3; str[k] != '\0'; k += 1)
5476 if (!isdigit (str[k]) && str[k] != '_')
5477 return 0;
14f9c5c9
AS
5478 return 1;
5479 }
4c4b4cd2 5480 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 5481 {
4c4b4cd2
PH
5482 for (k = 2; str[k] != '\0'; k += 1)
5483 if (!isdigit (str[k]) && str[k] != '_')
5484 return 0;
14f9c5c9
AS
5485 return 1;
5486 }
5487 return 0;
5488}
d2e4a39e 5489
aeb5907d
JB
5490/* Return non-zero if the string starting at NAME and ending before
5491 NAME_END contains no capital letters. */
529cad9c
PH
5492
5493static int
5494is_valid_name_for_wild_match (const char *name0)
5495{
5496 const char *decoded_name = ada_decode (name0);
5497 int i;
5498
5823c3ef
JB
5499 /* If the decoded name starts with an angle bracket, it means that
5500 NAME0 does not follow the GNAT encoding format. It should then
5501 not be allowed as a possible wild match. */
5502 if (decoded_name[0] == '<')
5503 return 0;
5504
529cad9c
PH
5505 for (i=0; decoded_name[i] != '\0'; i++)
5506 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5507 return 0;
5508
5509 return 1;
5510}
5511
73589123
PH
5512/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5513 that could start a simple name. Assumes that *NAMEP points into
5514 the string beginning at NAME0. */
4c4b4cd2 5515
14f9c5c9 5516static int
73589123 5517advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 5518{
73589123 5519 const char *name = *namep;
5b4ee69b 5520
5823c3ef 5521 while (1)
14f9c5c9 5522 {
aa27d0b3 5523 int t0, t1;
73589123
PH
5524
5525 t0 = *name;
5526 if (t0 == '_')
5527 {
5528 t1 = name[1];
5529 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5530 {
5531 name += 1;
5532 if (name == name0 + 5 && strncmp (name0, "_ada", 4) == 0)
5533 break;
5534 else
5535 name += 1;
5536 }
aa27d0b3
JB
5537 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5538 || name[2] == target0))
73589123
PH
5539 {
5540 name += 2;
5541 break;
5542 }
5543 else
5544 return 0;
5545 }
5546 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5547 name += 1;
5548 else
5823c3ef 5549 return 0;
73589123
PH
5550 }
5551
5552 *namep = name;
5553 return 1;
5554}
5555
5556/* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5557 informational suffixes of NAME (i.e., for which is_name_suffix is
5558 true). Assumes that PATN is a lower-cased Ada simple name. */
5559
5560static int
5561wild_match (const char *name, const char *patn)
5562{
22e048c9 5563 const char *p;
73589123
PH
5564 const char *name0 = name;
5565
5566 while (1)
5567 {
5568 const char *match = name;
5569
5570 if (*name == *patn)
5571 {
5572 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5573 if (*p != *name)
5574 break;
5575 if (*p == '\0' && is_name_suffix (name))
5576 return match != name0 && !is_valid_name_for_wild_match (name0);
5577
5578 if (name[-1] == '_')
5579 name -= 1;
5580 }
5581 if (!advance_wild_match (&name, name0, *patn))
5582 return 1;
96d887e8 5583 }
96d887e8
PH
5584}
5585
40658b94
PH
5586/* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
5587 informational suffix. */
5588
c4d840bd
PH
5589static int
5590full_match (const char *sym_name, const char *search_name)
5591{
40658b94 5592 return !match_name (sym_name, search_name, 0);
c4d840bd
PH
5593}
5594
5595
96d887e8
PH
5596/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5597 vector *defn_symbols, updating the list of symbols in OBSTACKP
0963b4bd 5598 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4eeaa230 5599 OBJFILE is the section containing BLOCK. */
96d887e8
PH
5600
5601static void
5602ada_add_block_symbols (struct obstack *obstackp,
76a01679 5603 struct block *block, const char *name,
96d887e8 5604 domain_enum domain, struct objfile *objfile,
2570f2b7 5605 int wild)
96d887e8 5606{
8157b174 5607 struct block_iterator iter;
96d887e8
PH
5608 int name_len = strlen (name);
5609 /* A matching argument symbol, if any. */
5610 struct symbol *arg_sym;
5611 /* Set true when we find a matching non-argument symbol. */
5612 int found_sym;
5613 struct symbol *sym;
5614
5615 arg_sym = NULL;
5616 found_sym = 0;
5617 if (wild)
5618 {
8157b174
TT
5619 for (sym = block_iter_match_first (block, name, wild_match, &iter);
5620 sym != NULL; sym = block_iter_match_next (name, wild_match, &iter))
76a01679 5621 {
5eeb2539
AR
5622 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5623 SYMBOL_DOMAIN (sym), domain)
73589123 5624 && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0)
76a01679 5625 {
2a2d4dc3
AS
5626 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5627 continue;
5628 else if (SYMBOL_IS_ARGUMENT (sym))
5629 arg_sym = sym;
5630 else
5631 {
76a01679
JB
5632 found_sym = 1;
5633 add_defn_to_vec (obstackp,
5634 fixup_symbol_section (sym, objfile),
2570f2b7 5635 block);
76a01679
JB
5636 }
5637 }
5638 }
96d887e8
PH
5639 }
5640 else
5641 {
8157b174
TT
5642 for (sym = block_iter_match_first (block, name, full_match, &iter);
5643 sym != NULL; sym = block_iter_match_next (name, full_match, &iter))
76a01679 5644 {
5eeb2539
AR
5645 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5646 SYMBOL_DOMAIN (sym), domain))
76a01679 5647 {
c4d840bd
PH
5648 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5649 {
5650 if (SYMBOL_IS_ARGUMENT (sym))
5651 arg_sym = sym;
5652 else
2a2d4dc3 5653 {
c4d840bd
PH
5654 found_sym = 1;
5655 add_defn_to_vec (obstackp,
5656 fixup_symbol_section (sym, objfile),
5657 block);
2a2d4dc3 5658 }
c4d840bd 5659 }
76a01679
JB
5660 }
5661 }
96d887e8
PH
5662 }
5663
5664 if (!found_sym && arg_sym != NULL)
5665 {
76a01679
JB
5666 add_defn_to_vec (obstackp,
5667 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5668 block);
96d887e8
PH
5669 }
5670
5671 if (!wild)
5672 {
5673 arg_sym = NULL;
5674 found_sym = 0;
5675
5676 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 5677 {
5eeb2539
AR
5678 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5679 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
5680 {
5681 int cmp;
5682
5683 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5684 if (cmp == 0)
5685 {
5686 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5687 if (cmp == 0)
5688 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5689 name_len);
5690 }
5691
5692 if (cmp == 0
5693 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5694 {
2a2d4dc3
AS
5695 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5696 {
5697 if (SYMBOL_IS_ARGUMENT (sym))
5698 arg_sym = sym;
5699 else
5700 {
5701 found_sym = 1;
5702 add_defn_to_vec (obstackp,
5703 fixup_symbol_section (sym, objfile),
5704 block);
5705 }
5706 }
76a01679
JB
5707 }
5708 }
76a01679 5709 }
96d887e8
PH
5710
5711 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5712 They aren't parameters, right? */
5713 if (!found_sym && arg_sym != NULL)
5714 {
5715 add_defn_to_vec (obstackp,
76a01679 5716 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5717 block);
96d887e8
PH
5718 }
5719 }
5720}
5721\f
41d27058
JB
5722
5723 /* Symbol Completion */
5724
5725/* If SYM_NAME is a completion candidate for TEXT, return this symbol
5726 name in a form that's appropriate for the completion. The result
5727 does not need to be deallocated, but is only good until the next call.
5728
5729 TEXT_LEN is equal to the length of TEXT.
e701b3c0 5730 Perform a wild match if WILD_MATCH_P is set.
6ea35997 5731 ENCODED_P should be set if TEXT represents the start of a symbol name
41d27058
JB
5732 in its encoded form. */
5733
5734static const char *
5735symbol_completion_match (const char *sym_name,
5736 const char *text, int text_len,
6ea35997 5737 int wild_match_p, int encoded_p)
41d27058 5738{
41d27058
JB
5739 const int verbatim_match = (text[0] == '<');
5740 int match = 0;
5741
5742 if (verbatim_match)
5743 {
5744 /* Strip the leading angle bracket. */
5745 text = text + 1;
5746 text_len--;
5747 }
5748
5749 /* First, test against the fully qualified name of the symbol. */
5750
5751 if (strncmp (sym_name, text, text_len) == 0)
5752 match = 1;
5753
6ea35997 5754 if (match && !encoded_p)
41d27058
JB
5755 {
5756 /* One needed check before declaring a positive match is to verify
5757 that iff we are doing a verbatim match, the decoded version
5758 of the symbol name starts with '<'. Otherwise, this symbol name
5759 is not a suitable completion. */
5760 const char *sym_name_copy = sym_name;
5761 int has_angle_bracket;
5762
5763 sym_name = ada_decode (sym_name);
5764 has_angle_bracket = (sym_name[0] == '<');
5765 match = (has_angle_bracket == verbatim_match);
5766 sym_name = sym_name_copy;
5767 }
5768
5769 if (match && !verbatim_match)
5770 {
5771 /* When doing non-verbatim match, another check that needs to
5772 be done is to verify that the potentially matching symbol name
5773 does not include capital letters, because the ada-mode would
5774 not be able to understand these symbol names without the
5775 angle bracket notation. */
5776 const char *tmp;
5777
5778 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5779 if (*tmp != '\0')
5780 match = 0;
5781 }
5782
5783 /* Second: Try wild matching... */
5784
e701b3c0 5785 if (!match && wild_match_p)
41d27058
JB
5786 {
5787 /* Since we are doing wild matching, this means that TEXT
5788 may represent an unqualified symbol name. We therefore must
5789 also compare TEXT against the unqualified name of the symbol. */
5790 sym_name = ada_unqualified_name (ada_decode (sym_name));
5791
5792 if (strncmp (sym_name, text, text_len) == 0)
5793 match = 1;
5794 }
5795
5796 /* Finally: If we found a mach, prepare the result to return. */
5797
5798 if (!match)
5799 return NULL;
5800
5801 if (verbatim_match)
5802 sym_name = add_angle_brackets (sym_name);
5803
6ea35997 5804 if (!encoded_p)
41d27058
JB
5805 sym_name = ada_decode (sym_name);
5806
5807 return sym_name;
5808}
5809
5810/* A companion function to ada_make_symbol_completion_list().
5811 Check if SYM_NAME represents a symbol which name would be suitable
5812 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5813 it is appended at the end of the given string vector SV.
5814
5815 ORIG_TEXT is the string original string from the user command
5816 that needs to be completed. WORD is the entire command on which
5817 completion should be performed. These two parameters are used to
5818 determine which part of the symbol name should be added to the
5819 completion vector.
c0af1706 5820 if WILD_MATCH_P is set, then wild matching is performed.
cb8e9b97 5821 ENCODED_P should be set if TEXT represents a symbol name in its
41d27058
JB
5822 encoded formed (in which case the completion should also be
5823 encoded). */
5824
5825static void
d6565258 5826symbol_completion_add (VEC(char_ptr) **sv,
41d27058
JB
5827 const char *sym_name,
5828 const char *text, int text_len,
5829 const char *orig_text, const char *word,
cb8e9b97 5830 int wild_match_p, int encoded_p)
41d27058
JB
5831{
5832 const char *match = symbol_completion_match (sym_name, text, text_len,
cb8e9b97 5833 wild_match_p, encoded_p);
41d27058
JB
5834 char *completion;
5835
5836 if (match == NULL)
5837 return;
5838
5839 /* We found a match, so add the appropriate completion to the given
5840 string vector. */
5841
5842 if (word == orig_text)
5843 {
5844 completion = xmalloc (strlen (match) + 5);
5845 strcpy (completion, match);
5846 }
5847 else if (word > orig_text)
5848 {
5849 /* Return some portion of sym_name. */
5850 completion = xmalloc (strlen (match) + 5);
5851 strcpy (completion, match + (word - orig_text));
5852 }
5853 else
5854 {
5855 /* Return some of ORIG_TEXT plus sym_name. */
5856 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
5857 strncpy (completion, word, orig_text - word);
5858 completion[orig_text - word] = '\0';
5859 strcat (completion, match);
5860 }
5861
d6565258 5862 VEC_safe_push (char_ptr, *sv, completion);
41d27058
JB
5863}
5864
ccefe4c4 5865/* An object of this type is passed as the user_data argument to the
7b08b9eb 5866 expand_partial_symbol_names method. */
ccefe4c4
TT
5867struct add_partial_datum
5868{
5869 VEC(char_ptr) **completions;
6f937416 5870 const char *text;
ccefe4c4 5871 int text_len;
6f937416
PA
5872 const char *text0;
5873 const char *word;
ccefe4c4
TT
5874 int wild_match;
5875 int encoded;
5876};
5877
7b08b9eb
JK
5878/* A callback for expand_partial_symbol_names. */
5879static int
e078317b 5880ada_expand_partial_symbol_name (const char *name, void *user_data)
ccefe4c4
TT
5881{
5882 struct add_partial_datum *data = user_data;
7b08b9eb
JK
5883
5884 return symbol_completion_match (name, data->text, data->text_len,
5885 data->wild_match, data->encoded) != NULL;
ccefe4c4
TT
5886}
5887
49c4e619
TT
5888/* Return a list of possible symbol names completing TEXT0. WORD is
5889 the entire command on which completion is made. */
41d27058 5890
49c4e619 5891static VEC (char_ptr) *
6f937416
PA
5892ada_make_symbol_completion_list (const char *text0, const char *word,
5893 enum type_code code)
41d27058
JB
5894{
5895 char *text;
5896 int text_len;
b1ed564a
JB
5897 int wild_match_p;
5898 int encoded_p;
2ba95b9b 5899 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
41d27058
JB
5900 struct symbol *sym;
5901 struct symtab *s;
41d27058
JB
5902 struct minimal_symbol *msymbol;
5903 struct objfile *objfile;
5904 struct block *b, *surrounding_static_block = 0;
5905 int i;
8157b174 5906 struct block_iterator iter;
b8fea896 5907 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
41d27058 5908
2f68a895
TT
5909 gdb_assert (code == TYPE_CODE_UNDEF);
5910
41d27058
JB
5911 if (text0[0] == '<')
5912 {
5913 text = xstrdup (text0);
5914 make_cleanup (xfree, text);
5915 text_len = strlen (text);
b1ed564a
JB
5916 wild_match_p = 0;
5917 encoded_p = 1;
41d27058
JB
5918 }
5919 else
5920 {
5921 text = xstrdup (ada_encode (text0));
5922 make_cleanup (xfree, text);
5923 text_len = strlen (text);
5924 for (i = 0; i < text_len; i++)
5925 text[i] = tolower (text[i]);
5926
b1ed564a 5927 encoded_p = (strstr (text0, "__") != NULL);
41d27058
JB
5928 /* If the name contains a ".", then the user is entering a fully
5929 qualified entity name, and the match must not be done in wild
5930 mode. Similarly, if the user wants to complete what looks like
5931 an encoded name, the match must not be done in wild mode. */
b1ed564a 5932 wild_match_p = (strchr (text0, '.') == NULL && !encoded_p);
41d27058
JB
5933 }
5934
5935 /* First, look at the partial symtab symbols. */
41d27058 5936 {
ccefe4c4
TT
5937 struct add_partial_datum data;
5938
5939 data.completions = &completions;
5940 data.text = text;
5941 data.text_len = text_len;
5942 data.text0 = text0;
5943 data.word = word;
b1ed564a
JB
5944 data.wild_match = wild_match_p;
5945 data.encoded = encoded_p;
7b08b9eb 5946 expand_partial_symbol_names (ada_expand_partial_symbol_name, &data);
41d27058
JB
5947 }
5948
5949 /* At this point scan through the misc symbol vectors and add each
5950 symbol you find to the list. Eventually we want to ignore
5951 anything that isn't a text symbol (everything else will be
5952 handled by the psymtab code above). */
5953
5954 ALL_MSYMBOLS (objfile, msymbol)
5955 {
5956 QUIT;
d6565258 5957 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol),
b1ed564a
JB
5958 text, text_len, text0, word, wild_match_p,
5959 encoded_p);
41d27058
JB
5960 }
5961
5962 /* Search upwards from currently selected frame (so that we can
5963 complete on local vars. */
5964
5965 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
5966 {
5967 if (!BLOCK_SUPERBLOCK (b))
5968 surrounding_static_block = b; /* For elmin of dups */
5969
5970 ALL_BLOCK_SYMBOLS (b, iter, sym)
5971 {
d6565258 5972 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 5973 text, text_len, text0, word,
b1ed564a 5974 wild_match_p, encoded_p);
41d27058
JB
5975 }
5976 }
5977
5978 /* Go through the symtabs and check the externs and statics for
5979 symbols which match. */
5980
5981 ALL_SYMTABS (objfile, s)
5982 {
5983 QUIT;
5984 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
5985 ALL_BLOCK_SYMBOLS (b, iter, sym)
5986 {
d6565258 5987 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 5988 text, text_len, text0, word,
b1ed564a 5989 wild_match_p, encoded_p);
41d27058
JB
5990 }
5991 }
5992
5993 ALL_SYMTABS (objfile, s)
5994 {
5995 QUIT;
5996 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
5997 /* Don't do this block twice. */
5998 if (b == surrounding_static_block)
5999 continue;
6000 ALL_BLOCK_SYMBOLS (b, iter, sym)
6001 {
d6565258 6002 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6003 text, text_len, text0, word,
b1ed564a 6004 wild_match_p, encoded_p);
41d27058
JB
6005 }
6006 }
6007
b8fea896 6008 do_cleanups (old_chain);
49c4e619 6009 return completions;
41d27058
JB
6010}
6011
963a6417 6012 /* Field Access */
96d887e8 6013
73fb9985
JB
6014/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6015 for tagged types. */
6016
6017static int
6018ada_is_dispatch_table_ptr_type (struct type *type)
6019{
0d5cff50 6020 const char *name;
73fb9985
JB
6021
6022 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6023 return 0;
6024
6025 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6026 if (name == NULL)
6027 return 0;
6028
6029 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6030}
6031
ac4a2da4
JG
6032/* Return non-zero if TYPE is an interface tag. */
6033
6034static int
6035ada_is_interface_tag (struct type *type)
6036{
6037 const char *name = TYPE_NAME (type);
6038
6039 if (name == NULL)
6040 return 0;
6041
6042 return (strcmp (name, "ada__tags__interface_tag") == 0);
6043}
6044
963a6417
PH
6045/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6046 to be invisible to users. */
96d887e8 6047
963a6417
PH
6048int
6049ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6050{
963a6417
PH
6051 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6052 return 1;
ffde82bf 6053
73fb9985
JB
6054 /* Check the name of that field. */
6055 {
6056 const char *name = TYPE_FIELD_NAME (type, field_num);
6057
6058 /* Anonymous field names should not be printed.
6059 brobecker/2007-02-20: I don't think this can actually happen
6060 but we don't want to print the value of annonymous fields anyway. */
6061 if (name == NULL)
6062 return 1;
6063
ffde82bf
JB
6064 /* Normally, fields whose name start with an underscore ("_")
6065 are fields that have been internally generated by the compiler,
6066 and thus should not be printed. The "_parent" field is special,
6067 however: This is a field internally generated by the compiler
6068 for tagged types, and it contains the components inherited from
6069 the parent type. This field should not be printed as is, but
6070 should not be ignored either. */
73fb9985
JB
6071 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
6072 return 1;
6073 }
6074
ac4a2da4
JG
6075 /* If this is the dispatch table of a tagged type or an interface tag,
6076 then ignore. */
73fb9985 6077 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6078 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6079 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6080 return 1;
6081
6082 /* Not a special field, so it should not be ignored. */
6083 return 0;
963a6417 6084}
96d887e8 6085
963a6417 6086/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6087 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6088
963a6417
PH
6089int
6090ada_is_tagged_type (struct type *type, int refok)
6091{
6092 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
6093}
96d887e8 6094
963a6417 6095/* True iff TYPE represents the type of X'Tag */
96d887e8 6096
963a6417
PH
6097int
6098ada_is_tag_type (struct type *type)
6099{
6100 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6101 return 0;
6102 else
96d887e8 6103 {
963a6417 6104 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6105
963a6417
PH
6106 return (name != NULL
6107 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6108 }
96d887e8
PH
6109}
6110
963a6417 6111/* The type of the tag on VAL. */
76a01679 6112
963a6417
PH
6113struct type *
6114ada_tag_type (struct value *val)
96d887e8 6115{
df407dfe 6116 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
963a6417 6117}
96d887e8 6118
b50d69b5
JG
6119/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6120 retired at Ada 05). */
6121
6122static int
6123is_ada95_tag (struct value *tag)
6124{
6125 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6126}
6127
963a6417 6128/* The value of the tag on VAL. */
96d887e8 6129
963a6417
PH
6130struct value *
6131ada_value_tag (struct value *val)
6132{
03ee6b2e 6133 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6134}
6135
963a6417
PH
6136/* The value of the tag on the object of type TYPE whose contents are
6137 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6138 ADDRESS. */
96d887e8 6139
963a6417 6140static struct value *
10a2c479 6141value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6142 const gdb_byte *valaddr,
963a6417 6143 CORE_ADDR address)
96d887e8 6144{
b5385fc0 6145 int tag_byte_offset;
963a6417 6146 struct type *tag_type;
5b4ee69b 6147
963a6417 6148 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6149 NULL, NULL, NULL))
96d887e8 6150 {
fc1a4b47 6151 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6152 ? NULL
6153 : valaddr + tag_byte_offset);
963a6417 6154 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6155
963a6417 6156 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6157 }
963a6417
PH
6158 return NULL;
6159}
96d887e8 6160
963a6417
PH
6161static struct type *
6162type_from_tag (struct value *tag)
6163{
6164 const char *type_name = ada_tag_name (tag);
5b4ee69b 6165
963a6417
PH
6166 if (type_name != NULL)
6167 return ada_find_any_type (ada_encode (type_name));
6168 return NULL;
6169}
96d887e8 6170
b50d69b5
JG
6171/* Given a value OBJ of a tagged type, return a value of this
6172 type at the base address of the object. The base address, as
6173 defined in Ada.Tags, it is the address of the primary tag of
6174 the object, and therefore where the field values of its full
6175 view can be fetched. */
6176
6177struct value *
6178ada_tag_value_at_base_address (struct value *obj)
6179{
6180 volatile struct gdb_exception e;
6181 struct value *val;
6182 LONGEST offset_to_top = 0;
6183 struct type *ptr_type, *obj_type;
6184 struct value *tag;
6185 CORE_ADDR base_address;
6186
6187 obj_type = value_type (obj);
6188
6189 /* It is the responsability of the caller to deref pointers. */
6190
6191 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6192 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6193 return obj;
6194
6195 tag = ada_value_tag (obj);
6196 if (!tag)
6197 return obj;
6198
6199 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6200
6201 if (is_ada95_tag (tag))
6202 return obj;
6203
6204 ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
6205 ptr_type = lookup_pointer_type (ptr_type);
6206 val = value_cast (ptr_type, tag);
6207 if (!val)
6208 return obj;
6209
6210 /* It is perfectly possible that an exception be raised while
6211 trying to determine the base address, just like for the tag;
6212 see ada_tag_name for more details. We do not print the error
6213 message for the same reason. */
6214
6215 TRY_CATCH (e, RETURN_MASK_ERROR)
6216 {
6217 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6218 }
6219
6220 if (e.reason < 0)
6221 return obj;
6222
6223 /* If offset is null, nothing to do. */
6224
6225 if (offset_to_top == 0)
6226 return obj;
6227
6228 /* -1 is a special case in Ada.Tags; however, what should be done
6229 is not quite clear from the documentation. So do nothing for
6230 now. */
6231
6232 if (offset_to_top == -1)
6233 return obj;
6234
6235 base_address = value_address (obj) - offset_to_top;
6236 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6237
6238 /* Make sure that we have a proper tag at the new address.
6239 Otherwise, offset_to_top is bogus (which can happen when
6240 the object is not initialized yet). */
6241
6242 if (!tag)
6243 return obj;
6244
6245 obj_type = type_from_tag (tag);
6246
6247 if (!obj_type)
6248 return obj;
6249
6250 return value_from_contents_and_address (obj_type, NULL, base_address);
6251}
6252
1b611343
JB
6253/* Return the "ada__tags__type_specific_data" type. */
6254
6255static struct type *
6256ada_get_tsd_type (struct inferior *inf)
963a6417 6257{
1b611343 6258 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6259
1b611343
JB
6260 if (data->tsd_type == 0)
6261 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6262 return data->tsd_type;
6263}
529cad9c 6264
1b611343
JB
6265/* Return the TSD (type-specific data) associated to the given TAG.
6266 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6267
1b611343 6268 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6269
1b611343
JB
6270static struct value *
6271ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6272{
4c4b4cd2 6273 struct value *val;
1b611343 6274 struct type *type;
5b4ee69b 6275
1b611343
JB
6276 /* First option: The TSD is simply stored as a field of our TAG.
6277 Only older versions of GNAT would use this format, but we have
6278 to test it first, because there are no visible markers for
6279 the current approach except the absence of that field. */
529cad9c 6280
1b611343
JB
6281 val = ada_value_struct_elt (tag, "tsd", 1);
6282 if (val)
6283 return val;
e802dbe0 6284
1b611343
JB
6285 /* Try the second representation for the dispatch table (in which
6286 there is no explicit 'tsd' field in the referent of the tag pointer,
6287 and instead the tsd pointer is stored just before the dispatch
6288 table. */
e802dbe0 6289
1b611343
JB
6290 type = ada_get_tsd_type (current_inferior());
6291 if (type == NULL)
6292 return NULL;
6293 type = lookup_pointer_type (lookup_pointer_type (type));
6294 val = value_cast (type, tag);
6295 if (val == NULL)
6296 return NULL;
6297 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6298}
6299
1b611343
JB
6300/* Given the TSD of a tag (type-specific data), return a string
6301 containing the name of the associated type.
6302
6303 The returned value is good until the next call. May return NULL
6304 if we are unable to determine the tag name. */
6305
6306static char *
6307ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6308{
529cad9c
PH
6309 static char name[1024];
6310 char *p;
1b611343 6311 struct value *val;
529cad9c 6312
1b611343 6313 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6314 if (val == NULL)
1b611343 6315 return NULL;
4c4b4cd2
PH
6316 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6317 for (p = name; *p != '\0'; p += 1)
6318 if (isalpha (*p))
6319 *p = tolower (*p);
1b611343 6320 return name;
4c4b4cd2
PH
6321}
6322
6323/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6324 a C string.
6325
6326 Return NULL if the TAG is not an Ada tag, or if we were unable to
6327 determine the name of that tag. The result is good until the next
6328 call. */
4c4b4cd2
PH
6329
6330const char *
6331ada_tag_name (struct value *tag)
6332{
1b611343
JB
6333 volatile struct gdb_exception e;
6334 char *name = NULL;
5b4ee69b 6335
df407dfe 6336 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6337 return NULL;
1b611343
JB
6338
6339 /* It is perfectly possible that an exception be raised while trying
6340 to determine the TAG's name, even under normal circumstances:
6341 The associated variable may be uninitialized or corrupted, for
6342 instance. We do not let any exception propagate past this point.
6343 instead we return NULL.
6344
6345 We also do not print the error message either (which often is very
6346 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6347 the caller print a more meaningful message if necessary. */
6348 TRY_CATCH (e, RETURN_MASK_ERROR)
6349 {
6350 struct value *tsd = ada_get_tsd_from_tag (tag);
6351
6352 if (tsd != NULL)
6353 name = ada_tag_name_from_tsd (tsd);
6354 }
6355
6356 return name;
4c4b4cd2
PH
6357}
6358
6359/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6360
d2e4a39e 6361struct type *
ebf56fd3 6362ada_parent_type (struct type *type)
14f9c5c9
AS
6363{
6364 int i;
6365
61ee279c 6366 type = ada_check_typedef (type);
14f9c5c9
AS
6367
6368 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6369 return NULL;
6370
6371 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6372 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6373 {
6374 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6375
6376 /* If the _parent field is a pointer, then dereference it. */
6377 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6378 parent_type = TYPE_TARGET_TYPE (parent_type);
6379 /* If there is a parallel XVS type, get the actual base type. */
6380 parent_type = ada_get_base_type (parent_type);
6381
6382 return ada_check_typedef (parent_type);
6383 }
14f9c5c9
AS
6384
6385 return NULL;
6386}
6387
4c4b4cd2
PH
6388/* True iff field number FIELD_NUM of structure type TYPE contains the
6389 parent-type (inherited) fields of a derived type. Assumes TYPE is
6390 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6391
6392int
ebf56fd3 6393ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6394{
61ee279c 6395 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6396
4c4b4cd2
PH
6397 return (name != NULL
6398 && (strncmp (name, "PARENT", 6) == 0
6399 || strncmp (name, "_parent", 7) == 0));
14f9c5c9
AS
6400}
6401
4c4b4cd2 6402/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6403 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6404 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6405 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6406 structures. */
14f9c5c9
AS
6407
6408int
ebf56fd3 6409ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6410{
d2e4a39e 6411 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6412
d2e4a39e 6413 return (name != NULL
4c4b4cd2
PH
6414 && (strncmp (name, "PARENT", 6) == 0
6415 || strcmp (name, "REP") == 0
6416 || strncmp (name, "_parent", 7) == 0
6417 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6418}
6419
4c4b4cd2
PH
6420/* True iff field number FIELD_NUM of structure or union type TYPE
6421 is a variant wrapper. Assumes TYPE is a structure type with at least
6422 FIELD_NUM+1 fields. */
14f9c5c9
AS
6423
6424int
ebf56fd3 6425ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6426{
d2e4a39e 6427 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6428
14f9c5c9 6429 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6430 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6431 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6432 == TYPE_CODE_UNION)));
14f9c5c9
AS
6433}
6434
6435/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6436 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6437 returns the type of the controlling discriminant for the variant.
6438 May return NULL if the type could not be found. */
14f9c5c9 6439
d2e4a39e 6440struct type *
ebf56fd3 6441ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6442{
d2e4a39e 6443 char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6444
7c964f07 6445 return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
14f9c5c9
AS
6446}
6447
4c4b4cd2 6448/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6449 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6450 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6451
6452int
ebf56fd3 6453ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6454{
d2e4a39e 6455 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6456
14f9c5c9
AS
6457 return (name != NULL && name[0] == 'O');
6458}
6459
6460/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
6461 returns the name of the discriminant controlling the variant.
6462 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 6463
d2e4a39e 6464char *
ebf56fd3 6465ada_variant_discrim_name (struct type *type0)
14f9c5c9 6466{
d2e4a39e 6467 static char *result = NULL;
14f9c5c9 6468 static size_t result_len = 0;
d2e4a39e
AS
6469 struct type *type;
6470 const char *name;
6471 const char *discrim_end;
6472 const char *discrim_start;
14f9c5c9
AS
6473
6474 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6475 type = TYPE_TARGET_TYPE (type0);
6476 else
6477 type = type0;
6478
6479 name = ada_type_name (type);
6480
6481 if (name == NULL || name[0] == '\000')
6482 return "";
6483
6484 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6485 discrim_end -= 1)
6486 {
4c4b4cd2
PH
6487 if (strncmp (discrim_end, "___XVN", 6) == 0)
6488 break;
14f9c5c9
AS
6489 }
6490 if (discrim_end == name)
6491 return "";
6492
d2e4a39e 6493 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
6494 discrim_start -= 1)
6495 {
d2e4a39e 6496 if (discrim_start == name + 1)
4c4b4cd2 6497 return "";
76a01679 6498 if ((discrim_start > name + 3
4c4b4cd2
PH
6499 && strncmp (discrim_start - 3, "___", 3) == 0)
6500 || discrim_start[-1] == '.')
6501 break;
14f9c5c9
AS
6502 }
6503
6504 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6505 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 6506 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
6507 return result;
6508}
6509
4c4b4cd2
PH
6510/* Scan STR for a subtype-encoded number, beginning at position K.
6511 Put the position of the character just past the number scanned in
6512 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6513 Return 1 if there was a valid number at the given position, and 0
6514 otherwise. A "subtype-encoded" number consists of the absolute value
6515 in decimal, followed by the letter 'm' to indicate a negative number.
6516 Assumes 0m does not occur. */
14f9c5c9
AS
6517
6518int
d2e4a39e 6519ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
6520{
6521 ULONGEST RU;
6522
d2e4a39e 6523 if (!isdigit (str[k]))
14f9c5c9
AS
6524 return 0;
6525
4c4b4cd2 6526 /* Do it the hard way so as not to make any assumption about
14f9c5c9 6527 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 6528 LONGEST. */
14f9c5c9
AS
6529 RU = 0;
6530 while (isdigit (str[k]))
6531 {
d2e4a39e 6532 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
6533 k += 1;
6534 }
6535
d2e4a39e 6536 if (str[k] == 'm')
14f9c5c9
AS
6537 {
6538 if (R != NULL)
4c4b4cd2 6539 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
6540 k += 1;
6541 }
6542 else if (R != NULL)
6543 *R = (LONGEST) RU;
6544
4c4b4cd2 6545 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
6546 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6547 number representable as a LONGEST (although either would probably work
6548 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 6549 above is always equivalent to the negative of RU. */
14f9c5c9
AS
6550
6551 if (new_k != NULL)
6552 *new_k = k;
6553 return 1;
6554}
6555
4c4b4cd2
PH
6556/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6557 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6558 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 6559
d2e4a39e 6560int
ebf56fd3 6561ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 6562{
d2e4a39e 6563 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
6564 int p;
6565
6566 p = 0;
6567 while (1)
6568 {
d2e4a39e 6569 switch (name[p])
4c4b4cd2
PH
6570 {
6571 case '\0':
6572 return 0;
6573 case 'S':
6574 {
6575 LONGEST W;
5b4ee69b 6576
4c4b4cd2
PH
6577 if (!ada_scan_number (name, p + 1, &W, &p))
6578 return 0;
6579 if (val == W)
6580 return 1;
6581 break;
6582 }
6583 case 'R':
6584 {
6585 LONGEST L, U;
5b4ee69b 6586
4c4b4cd2
PH
6587 if (!ada_scan_number (name, p + 1, &L, &p)
6588 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6589 return 0;
6590 if (val >= L && val <= U)
6591 return 1;
6592 break;
6593 }
6594 case 'O':
6595 return 1;
6596 default:
6597 return 0;
6598 }
6599 }
6600}
6601
0963b4bd 6602/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
6603
6604/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6605 ARG_TYPE, extract and return the value of one of its (non-static)
6606 fields. FIELDNO says which field. Differs from value_primitive_field
6607 only in that it can handle packed values of arbitrary type. */
14f9c5c9 6608
4c4b4cd2 6609static struct value *
d2e4a39e 6610ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 6611 struct type *arg_type)
14f9c5c9 6612{
14f9c5c9
AS
6613 struct type *type;
6614
61ee279c 6615 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
6616 type = TYPE_FIELD_TYPE (arg_type, fieldno);
6617
4c4b4cd2 6618 /* Handle packed fields. */
14f9c5c9
AS
6619
6620 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
6621 {
6622 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6623 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 6624
0fd88904 6625 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
6626 offset + bit_pos / 8,
6627 bit_pos % 8, bit_size, type);
14f9c5c9
AS
6628 }
6629 else
6630 return value_primitive_field (arg1, offset, fieldno, arg_type);
6631}
6632
52ce6436
PH
6633/* Find field with name NAME in object of type TYPE. If found,
6634 set the following for each argument that is non-null:
6635 - *FIELD_TYPE_P to the field's type;
6636 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6637 an object of that type;
6638 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6639 - *BIT_SIZE_P to its size in bits if the field is packed, and
6640 0 otherwise;
6641 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6642 fields up to but not including the desired field, or by the total
6643 number of fields if not found. A NULL value of NAME never
6644 matches; the function just counts visible fields in this case.
6645
0963b4bd 6646 Returns 1 if found, 0 otherwise. */
52ce6436 6647
4c4b4cd2 6648static int
0d5cff50 6649find_struct_field (const char *name, struct type *type, int offset,
76a01679 6650 struct type **field_type_p,
52ce6436
PH
6651 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6652 int *index_p)
4c4b4cd2
PH
6653{
6654 int i;
6655
61ee279c 6656 type = ada_check_typedef (type);
76a01679 6657
52ce6436
PH
6658 if (field_type_p != NULL)
6659 *field_type_p = NULL;
6660 if (byte_offset_p != NULL)
d5d6fca5 6661 *byte_offset_p = 0;
52ce6436
PH
6662 if (bit_offset_p != NULL)
6663 *bit_offset_p = 0;
6664 if (bit_size_p != NULL)
6665 *bit_size_p = 0;
6666
6667 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
6668 {
6669 int bit_pos = TYPE_FIELD_BITPOS (type, i);
6670 int fld_offset = offset + bit_pos / 8;
0d5cff50 6671 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 6672
4c4b4cd2
PH
6673 if (t_field_name == NULL)
6674 continue;
6675
52ce6436 6676 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
6677 {
6678 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 6679
52ce6436
PH
6680 if (field_type_p != NULL)
6681 *field_type_p = TYPE_FIELD_TYPE (type, i);
6682 if (byte_offset_p != NULL)
6683 *byte_offset_p = fld_offset;
6684 if (bit_offset_p != NULL)
6685 *bit_offset_p = bit_pos % 8;
6686 if (bit_size_p != NULL)
6687 *bit_size_p = bit_size;
76a01679
JB
6688 return 1;
6689 }
4c4b4cd2
PH
6690 else if (ada_is_wrapper_field (type, i))
6691 {
52ce6436
PH
6692 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
6693 field_type_p, byte_offset_p, bit_offset_p,
6694 bit_size_p, index_p))
76a01679
JB
6695 return 1;
6696 }
4c4b4cd2
PH
6697 else if (ada_is_variant_part (type, i))
6698 {
52ce6436
PH
6699 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6700 fixed type?? */
4c4b4cd2 6701 int j;
52ce6436
PH
6702 struct type *field_type
6703 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 6704
52ce6436 6705 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6706 {
76a01679
JB
6707 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
6708 fld_offset
6709 + TYPE_FIELD_BITPOS (field_type, j) / 8,
6710 field_type_p, byte_offset_p,
52ce6436 6711 bit_offset_p, bit_size_p, index_p))
76a01679 6712 return 1;
4c4b4cd2
PH
6713 }
6714 }
52ce6436
PH
6715 else if (index_p != NULL)
6716 *index_p += 1;
4c4b4cd2
PH
6717 }
6718 return 0;
6719}
6720
0963b4bd 6721/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 6722
52ce6436
PH
6723static int
6724num_visible_fields (struct type *type)
6725{
6726 int n;
5b4ee69b 6727
52ce6436
PH
6728 n = 0;
6729 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6730 return n;
6731}
14f9c5c9 6732
4c4b4cd2 6733/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
6734 and search in it assuming it has (class) type TYPE.
6735 If found, return value, else return NULL.
6736
4c4b4cd2 6737 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 6738
4c4b4cd2 6739static struct value *
d2e4a39e 6740ada_search_struct_field (char *name, struct value *arg, int offset,
4c4b4cd2 6741 struct type *type)
14f9c5c9
AS
6742{
6743 int i;
14f9c5c9 6744
5b4ee69b 6745 type = ada_check_typedef (type);
52ce6436 6746 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 6747 {
0d5cff50 6748 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
6749
6750 if (t_field_name == NULL)
4c4b4cd2 6751 continue;
14f9c5c9
AS
6752
6753 else if (field_name_match (t_field_name, name))
4c4b4cd2 6754 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
6755
6756 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 6757 {
0963b4bd 6758 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
6759 ada_search_struct_field (name, arg,
6760 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6761 TYPE_FIELD_TYPE (type, i));
5b4ee69b 6762
4c4b4cd2
PH
6763 if (v != NULL)
6764 return v;
6765 }
14f9c5c9
AS
6766
6767 else if (ada_is_variant_part (type, i))
4c4b4cd2 6768 {
0963b4bd 6769 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 6770 int j;
5b4ee69b
MS
6771 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
6772 i));
4c4b4cd2
PH
6773 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6774
52ce6436 6775 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6776 {
0963b4bd
MS
6777 struct value *v = ada_search_struct_field /* Force line
6778 break. */
06d5cf63
JB
6779 (name, arg,
6780 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6781 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 6782
4c4b4cd2
PH
6783 if (v != NULL)
6784 return v;
6785 }
6786 }
14f9c5c9
AS
6787 }
6788 return NULL;
6789}
d2e4a39e 6790
52ce6436
PH
6791static struct value *ada_index_struct_field_1 (int *, struct value *,
6792 int, struct type *);
6793
6794
6795/* Return field #INDEX in ARG, where the index is that returned by
6796 * find_struct_field through its INDEX_P argument. Adjust the address
6797 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 6798 * If found, return value, else return NULL. */
52ce6436
PH
6799
6800static struct value *
6801ada_index_struct_field (int index, struct value *arg, int offset,
6802 struct type *type)
6803{
6804 return ada_index_struct_field_1 (&index, arg, offset, type);
6805}
6806
6807
6808/* Auxiliary function for ada_index_struct_field. Like
6809 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 6810 * *INDEX_P. */
52ce6436
PH
6811
6812static struct value *
6813ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6814 struct type *type)
6815{
6816 int i;
6817 type = ada_check_typedef (type);
6818
6819 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6820 {
6821 if (TYPE_FIELD_NAME (type, i) == NULL)
6822 continue;
6823 else if (ada_is_wrapper_field (type, i))
6824 {
0963b4bd 6825 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
6826 ada_index_struct_field_1 (index_p, arg,
6827 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6828 TYPE_FIELD_TYPE (type, i));
5b4ee69b 6829
52ce6436
PH
6830 if (v != NULL)
6831 return v;
6832 }
6833
6834 else if (ada_is_variant_part (type, i))
6835 {
6836 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 6837 find_struct_field. */
52ce6436
PH
6838 error (_("Cannot assign this kind of variant record"));
6839 }
6840 else if (*index_p == 0)
6841 return ada_value_primitive_field (arg, offset, i, type);
6842 else
6843 *index_p -= 1;
6844 }
6845 return NULL;
6846}
6847
4c4b4cd2
PH
6848/* Given ARG, a value of type (pointer or reference to a)*
6849 structure/union, extract the component named NAME from the ultimate
6850 target structure/union and return it as a value with its
f5938064 6851 appropriate type.
14f9c5c9 6852
4c4b4cd2
PH
6853 The routine searches for NAME among all members of the structure itself
6854 and (recursively) among all members of any wrapper members
14f9c5c9
AS
6855 (e.g., '_parent').
6856
03ee6b2e
PH
6857 If NO_ERR, then simply return NULL in case of error, rather than
6858 calling error. */
14f9c5c9 6859
d2e4a39e 6860struct value *
03ee6b2e 6861ada_value_struct_elt (struct value *arg, char *name, int no_err)
14f9c5c9 6862{
4c4b4cd2 6863 struct type *t, *t1;
d2e4a39e 6864 struct value *v;
14f9c5c9 6865
4c4b4cd2 6866 v = NULL;
df407dfe 6867 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
6868 if (TYPE_CODE (t) == TYPE_CODE_REF)
6869 {
6870 t1 = TYPE_TARGET_TYPE (t);
6871 if (t1 == NULL)
03ee6b2e 6872 goto BadValue;
61ee279c 6873 t1 = ada_check_typedef (t1);
4c4b4cd2 6874 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 6875 {
994b9211 6876 arg = coerce_ref (arg);
76a01679
JB
6877 t = t1;
6878 }
4c4b4cd2 6879 }
14f9c5c9 6880
4c4b4cd2
PH
6881 while (TYPE_CODE (t) == TYPE_CODE_PTR)
6882 {
6883 t1 = TYPE_TARGET_TYPE (t);
6884 if (t1 == NULL)
03ee6b2e 6885 goto BadValue;
61ee279c 6886 t1 = ada_check_typedef (t1);
4c4b4cd2 6887 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
6888 {
6889 arg = value_ind (arg);
6890 t = t1;
6891 }
4c4b4cd2 6892 else
76a01679 6893 break;
4c4b4cd2 6894 }
14f9c5c9 6895
4c4b4cd2 6896 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 6897 goto BadValue;
14f9c5c9 6898
4c4b4cd2
PH
6899 if (t1 == t)
6900 v = ada_search_struct_field (name, arg, 0, t);
6901 else
6902 {
6903 int bit_offset, bit_size, byte_offset;
6904 struct type *field_type;
6905 CORE_ADDR address;
6906
76a01679 6907 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 6908 address = value_address (ada_value_ind (arg));
4c4b4cd2 6909 else
b50d69b5 6910 address = value_address (ada_coerce_ref (arg));
14f9c5c9 6911
1ed6ede0 6912 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
76a01679
JB
6913 if (find_struct_field (name, t1, 0,
6914 &field_type, &byte_offset, &bit_offset,
52ce6436 6915 &bit_size, NULL))
76a01679
JB
6916 {
6917 if (bit_size != 0)
6918 {
714e53ab
PH
6919 if (TYPE_CODE (t) == TYPE_CODE_REF)
6920 arg = ada_coerce_ref (arg);
6921 else
6922 arg = ada_value_ind (arg);
76a01679
JB
6923 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
6924 bit_offset, bit_size,
6925 field_type);
6926 }
6927 else
f5938064 6928 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
6929 }
6930 }
6931
03ee6b2e
PH
6932 if (v != NULL || no_err)
6933 return v;
6934 else
323e0a4a 6935 error (_("There is no member named %s."), name);
14f9c5c9 6936
03ee6b2e
PH
6937 BadValue:
6938 if (no_err)
6939 return NULL;
6940 else
0963b4bd
MS
6941 error (_("Attempt to extract a component of "
6942 "a value that is not a record."));
14f9c5c9
AS
6943}
6944
6945/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
6946 If DISPP is non-null, add its byte displacement from the beginning of a
6947 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
6948 work for packed fields).
6949
6950 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 6951 followed by "___".
14f9c5c9 6952
0963b4bd 6953 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
6954 be a (pointer or reference)+ to a struct or union, and the
6955 ultimate target type will be searched.
14f9c5c9
AS
6956
6957 Looks recursively into variant clauses and parent types.
6958
4c4b4cd2
PH
6959 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6960 TYPE is not a type of the right kind. */
14f9c5c9 6961
4c4b4cd2 6962static struct type *
76a01679
JB
6963ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
6964 int noerr, int *dispp)
14f9c5c9
AS
6965{
6966 int i;
6967
6968 if (name == NULL)
6969 goto BadName;
6970
76a01679 6971 if (refok && type != NULL)
4c4b4cd2
PH
6972 while (1)
6973 {
61ee279c 6974 type = ada_check_typedef (type);
76a01679
JB
6975 if (TYPE_CODE (type) != TYPE_CODE_PTR
6976 && TYPE_CODE (type) != TYPE_CODE_REF)
6977 break;
6978 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 6979 }
14f9c5c9 6980
76a01679 6981 if (type == NULL
1265e4aa
JB
6982 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
6983 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 6984 {
4c4b4cd2 6985 if (noerr)
76a01679 6986 return NULL;
4c4b4cd2 6987 else
76a01679
JB
6988 {
6989 target_terminal_ours ();
6990 gdb_flush (gdb_stdout);
323e0a4a
AC
6991 if (type == NULL)
6992 error (_("Type (null) is not a structure or union type"));
6993 else
6994 {
6995 /* XXX: type_sprint */
6996 fprintf_unfiltered (gdb_stderr, _("Type "));
6997 type_print (type, "", gdb_stderr, -1);
6998 error (_(" is not a structure or union type"));
6999 }
76a01679 7000 }
14f9c5c9
AS
7001 }
7002
7003 type = to_static_fixed_type (type);
7004
7005 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7006 {
0d5cff50 7007 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7008 struct type *t;
7009 int disp;
d2e4a39e 7010
14f9c5c9 7011 if (t_field_name == NULL)
4c4b4cd2 7012 continue;
14f9c5c9
AS
7013
7014 else if (field_name_match (t_field_name, name))
4c4b4cd2
PH
7015 {
7016 if (dispp != NULL)
7017 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
61ee279c 7018 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7019 }
14f9c5c9
AS
7020
7021 else if (ada_is_wrapper_field (type, i))
4c4b4cd2
PH
7022 {
7023 disp = 0;
7024 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7025 0, 1, &disp);
7026 if (t != NULL)
7027 {
7028 if (dispp != NULL)
7029 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7030 return t;
7031 }
7032 }
14f9c5c9
AS
7033
7034 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7035 {
7036 int j;
5b4ee69b
MS
7037 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7038 i));
4c4b4cd2
PH
7039
7040 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7041 {
b1f33ddd
JB
7042 /* FIXME pnh 2008/01/26: We check for a field that is
7043 NOT wrapped in a struct, since the compiler sometimes
7044 generates these for unchecked variant types. Revisit
0963b4bd 7045 if the compiler changes this practice. */
0d5cff50 7046 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
4c4b4cd2 7047 disp = 0;
b1f33ddd
JB
7048 if (v_field_name != NULL
7049 && field_name_match (v_field_name, name))
7050 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
7051 else
0963b4bd
MS
7052 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7053 j),
b1f33ddd
JB
7054 name, 0, 1, &disp);
7055
4c4b4cd2
PH
7056 if (t != NULL)
7057 {
7058 if (dispp != NULL)
7059 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7060 return t;
7061 }
7062 }
7063 }
14f9c5c9
AS
7064
7065 }
7066
7067BadName:
d2e4a39e 7068 if (!noerr)
14f9c5c9
AS
7069 {
7070 target_terminal_ours ();
7071 gdb_flush (gdb_stdout);
323e0a4a
AC
7072 if (name == NULL)
7073 {
7074 /* XXX: type_sprint */
7075 fprintf_unfiltered (gdb_stderr, _("Type "));
7076 type_print (type, "", gdb_stderr, -1);
7077 error (_(" has no component named <null>"));
7078 }
7079 else
7080 {
7081 /* XXX: type_sprint */
7082 fprintf_unfiltered (gdb_stderr, _("Type "));
7083 type_print (type, "", gdb_stderr, -1);
7084 error (_(" has no component named %s"), name);
7085 }
14f9c5c9
AS
7086 }
7087
7088 return NULL;
7089}
7090
b1f33ddd
JB
7091/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7092 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7093 represents an unchecked union (that is, the variant part of a
0963b4bd 7094 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7095
7096static int
7097is_unchecked_variant (struct type *var_type, struct type *outer_type)
7098{
7099 char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7100
b1f33ddd
JB
7101 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
7102 == NULL);
7103}
7104
7105
14f9c5c9
AS
7106/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7107 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7108 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7109 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7110
d2e4a39e 7111int
ebf56fd3 7112ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7113 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7114{
7115 int others_clause;
7116 int i;
d2e4a39e 7117 char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7118 struct value *outer;
7119 struct value *discrim;
14f9c5c9
AS
7120 LONGEST discrim_val;
7121
0c281816
JB
7122 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
7123 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7124 if (discrim == NULL)
14f9c5c9 7125 return -1;
0c281816 7126 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7127
7128 others_clause = -1;
7129 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7130 {
7131 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7132 others_clause = i;
14f9c5c9 7133 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7134 return i;
14f9c5c9
AS
7135 }
7136
7137 return others_clause;
7138}
d2e4a39e 7139\f
14f9c5c9
AS
7140
7141
4c4b4cd2 7142 /* Dynamic-Sized Records */
14f9c5c9
AS
7143
7144/* Strategy: The type ostensibly attached to a value with dynamic size
7145 (i.e., a size that is not statically recorded in the debugging
7146 data) does not accurately reflect the size or layout of the value.
7147 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7148 conventional types that are constructed on the fly. */
14f9c5c9
AS
7149
7150/* There is a subtle and tricky problem here. In general, we cannot
7151 determine the size of dynamic records without its data. However,
7152 the 'struct value' data structure, which GDB uses to represent
7153 quantities in the inferior process (the target), requires the size
7154 of the type at the time of its allocation in order to reserve space
7155 for GDB's internal copy of the data. That's why the
7156 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7157 rather than struct value*s.
14f9c5c9
AS
7158
7159 However, GDB's internal history variables ($1, $2, etc.) are
7160 struct value*s containing internal copies of the data that are not, in
7161 general, the same as the data at their corresponding addresses in
7162 the target. Fortunately, the types we give to these values are all
7163 conventional, fixed-size types (as per the strategy described
7164 above), so that we don't usually have to perform the
7165 'to_fixed_xxx_type' conversions to look at their values.
7166 Unfortunately, there is one exception: if one of the internal
7167 history variables is an array whose elements are unconstrained
7168 records, then we will need to create distinct fixed types for each
7169 element selected. */
7170
7171/* The upshot of all of this is that many routines take a (type, host
7172 address, target address) triple as arguments to represent a value.
7173 The host address, if non-null, is supposed to contain an internal
7174 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7175 target at the target address. */
14f9c5c9
AS
7176
7177/* Assuming that VAL0 represents a pointer value, the result of
7178 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7179 dynamic-sized types. */
14f9c5c9 7180
d2e4a39e
AS
7181struct value *
7182ada_value_ind (struct value *val0)
14f9c5c9 7183{
c48db5ca 7184 struct value *val = value_ind (val0);
5b4ee69b 7185
b50d69b5
JG
7186 if (ada_is_tagged_type (value_type (val), 0))
7187 val = ada_tag_value_at_base_address (val);
7188
4c4b4cd2 7189 return ada_to_fixed_value (val);
14f9c5c9
AS
7190}
7191
7192/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7193 qualifiers on VAL0. */
7194
d2e4a39e
AS
7195static struct value *
7196ada_coerce_ref (struct value *val0)
7197{
df407dfe 7198 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7199 {
7200 struct value *val = val0;
5b4ee69b 7201
994b9211 7202 val = coerce_ref (val);
b50d69b5
JG
7203
7204 if (ada_is_tagged_type (value_type (val), 0))
7205 val = ada_tag_value_at_base_address (val);
7206
4c4b4cd2 7207 return ada_to_fixed_value (val);
d2e4a39e
AS
7208 }
7209 else
14f9c5c9
AS
7210 return val0;
7211}
7212
7213/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7214 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7215
7216static unsigned int
ebf56fd3 7217align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7218{
7219 return (off + alignment - 1) & ~(alignment - 1);
7220}
7221
4c4b4cd2 7222/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7223
7224static unsigned int
ebf56fd3 7225field_alignment (struct type *type, int f)
14f9c5c9 7226{
d2e4a39e 7227 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7228 int len;
14f9c5c9
AS
7229 int align_offset;
7230
64a1bf19
JB
7231 /* The field name should never be null, unless the debugging information
7232 is somehow malformed. In this case, we assume the field does not
7233 require any alignment. */
7234 if (name == NULL)
7235 return 1;
7236
7237 len = strlen (name);
7238
4c4b4cd2
PH
7239 if (!isdigit (name[len - 1]))
7240 return 1;
14f9c5c9 7241
d2e4a39e 7242 if (isdigit (name[len - 2]))
14f9c5c9
AS
7243 align_offset = len - 2;
7244 else
7245 align_offset = len - 1;
7246
4c4b4cd2 7247 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
14f9c5c9
AS
7248 return TARGET_CHAR_BIT;
7249
4c4b4cd2
PH
7250 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7251}
7252
852dff6c 7253/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7254
852dff6c
JB
7255static struct symbol *
7256ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7257{
7258 struct symbol *sym;
7259
7260 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7261 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7262 return sym;
7263
7264 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7265 return sym;
14f9c5c9
AS
7266}
7267
dddfab26
UW
7268/* Find a type named NAME. Ignores ambiguity. This routine will look
7269 solely for types defined by debug info, it will not search the GDB
7270 primitive types. */
4c4b4cd2 7271
852dff6c 7272static struct type *
ebf56fd3 7273ada_find_any_type (const char *name)
14f9c5c9 7274{
852dff6c 7275 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7276
14f9c5c9 7277 if (sym != NULL)
dddfab26 7278 return SYMBOL_TYPE (sym);
14f9c5c9 7279
dddfab26 7280 return NULL;
14f9c5c9
AS
7281}
7282
739593e0
JB
7283/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7284 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7285 symbol, in which case it is returned. Otherwise, this looks for
7286 symbols whose name is that of NAME_SYM suffixed with "___XR".
7287 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7288
7289struct symbol *
270140bd 7290ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7291{
739593e0 7292 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7293 struct symbol *sym;
7294
739593e0
JB
7295 if (strstr (name, "___XR") != NULL)
7296 return name_sym;
7297
aeb5907d
JB
7298 sym = find_old_style_renaming_symbol (name, block);
7299
7300 if (sym != NULL)
7301 return sym;
7302
0963b4bd 7303 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7304 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7305 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7306 return sym;
7307 else
7308 return NULL;
7309}
7310
7311static struct symbol *
270140bd 7312find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 7313{
7f0df278 7314 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
7315 char *rename;
7316
7317 if (function_sym != NULL)
7318 {
7319 /* If the symbol is defined inside a function, NAME is not fully
7320 qualified. This means we need to prepend the function name
7321 as well as adding the ``___XR'' suffix to build the name of
7322 the associated renaming symbol. */
0d5cff50 7323 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
7324 /* Function names sometimes contain suffixes used
7325 for instance to qualify nested subprograms. When building
7326 the XR type name, we need to make sure that this suffix is
7327 not included. So do not include any suffix in the function
7328 name length below. */
69fadcdf 7329 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
7330 const int rename_len = function_name_len + 2 /* "__" */
7331 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 7332
529cad9c 7333 /* Strip the suffix if necessary. */
69fadcdf
JB
7334 ada_remove_trailing_digits (function_name, &function_name_len);
7335 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7336 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 7337
4c4b4cd2
PH
7338 /* Library-level functions are a special case, as GNAT adds
7339 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 7340 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
7341 have this prefix, so we need to skip this prefix if present. */
7342 if (function_name_len > 5 /* "_ada_" */
7343 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
7344 {
7345 function_name += 5;
7346 function_name_len -= 5;
7347 }
4c4b4cd2
PH
7348
7349 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
7350 strncpy (rename, function_name, function_name_len);
7351 xsnprintf (rename + function_name_len, rename_len - function_name_len,
7352 "__%s___XR", name);
4c4b4cd2
PH
7353 }
7354 else
7355 {
7356 const int rename_len = strlen (name) + 6;
5b4ee69b 7357
4c4b4cd2 7358 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 7359 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
7360 }
7361
852dff6c 7362 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
7363}
7364
14f9c5c9 7365/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 7366 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 7367 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
7368 otherwise return 0. */
7369
14f9c5c9 7370int
d2e4a39e 7371ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
7372{
7373 if (type1 == NULL)
7374 return 1;
7375 else if (type0 == NULL)
7376 return 0;
7377 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7378 return 1;
7379 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7380 return 0;
4c4b4cd2
PH
7381 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7382 return 1;
ad82864c 7383 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 7384 return 1;
4c4b4cd2
PH
7385 else if (ada_is_array_descriptor_type (type0)
7386 && !ada_is_array_descriptor_type (type1))
14f9c5c9 7387 return 1;
aeb5907d
JB
7388 else
7389 {
7390 const char *type0_name = type_name_no_tag (type0);
7391 const char *type1_name = type_name_no_tag (type1);
7392
7393 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7394 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7395 return 1;
7396 }
14f9c5c9
AS
7397 return 0;
7398}
7399
7400/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
7401 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7402
0d5cff50 7403const char *
d2e4a39e 7404ada_type_name (struct type *type)
14f9c5c9 7405{
d2e4a39e 7406 if (type == NULL)
14f9c5c9
AS
7407 return NULL;
7408 else if (TYPE_NAME (type) != NULL)
7409 return TYPE_NAME (type);
7410 else
7411 return TYPE_TAG_NAME (type);
7412}
7413
b4ba55a1
JB
7414/* Search the list of "descriptive" types associated to TYPE for a type
7415 whose name is NAME. */
7416
7417static struct type *
7418find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7419{
7420 struct type *result;
7421
7422 /* If there no descriptive-type info, then there is no parallel type
7423 to be found. */
7424 if (!HAVE_GNAT_AUX_INFO (type))
7425 return NULL;
7426
7427 result = TYPE_DESCRIPTIVE_TYPE (type);
7428 while (result != NULL)
7429 {
0d5cff50 7430 const char *result_name = ada_type_name (result);
b4ba55a1
JB
7431
7432 if (result_name == NULL)
7433 {
7434 warning (_("unexpected null name on descriptive type"));
7435 return NULL;
7436 }
7437
7438 /* If the names match, stop. */
7439 if (strcmp (result_name, name) == 0)
7440 break;
7441
7442 /* Otherwise, look at the next item on the list, if any. */
7443 if (HAVE_GNAT_AUX_INFO (result))
7444 result = TYPE_DESCRIPTIVE_TYPE (result);
7445 else
7446 result = NULL;
7447 }
7448
7449 /* If we didn't find a match, see whether this is a packed array. With
7450 older compilers, the descriptive type information is either absent or
7451 irrelevant when it comes to packed arrays so the above lookup fails.
7452 Fall back to using a parallel lookup by name in this case. */
12ab9e09 7453 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
7454 return ada_find_any_type (name);
7455
7456 return result;
7457}
7458
7459/* Find a parallel type to TYPE with the specified NAME, using the
7460 descriptive type taken from the debugging information, if available,
7461 and otherwise using the (slower) name-based method. */
7462
7463static struct type *
7464ada_find_parallel_type_with_name (struct type *type, const char *name)
7465{
7466 struct type *result = NULL;
7467
7468 if (HAVE_GNAT_AUX_INFO (type))
7469 result = find_parallel_type_by_descriptive_type (type, name);
7470 else
7471 result = ada_find_any_type (name);
7472
7473 return result;
7474}
7475
7476/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 7477 SUFFIX to the name of TYPE. */
14f9c5c9 7478
d2e4a39e 7479struct type *
ebf56fd3 7480ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 7481{
0d5cff50
DE
7482 char *name;
7483 const char *typename = ada_type_name (type);
14f9c5c9 7484 int len;
d2e4a39e 7485
14f9c5c9
AS
7486 if (typename == NULL)
7487 return NULL;
7488
7489 len = strlen (typename);
7490
b4ba55a1 7491 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9
AS
7492
7493 strcpy (name, typename);
7494 strcpy (name + len, suffix);
7495
b4ba55a1 7496 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
7497}
7498
14f9c5c9 7499/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 7500 type describing its fields. Otherwise, return NULL. */
14f9c5c9 7501
d2e4a39e
AS
7502static struct type *
7503dynamic_template_type (struct type *type)
14f9c5c9 7504{
61ee279c 7505 type = ada_check_typedef (type);
14f9c5c9
AS
7506
7507 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 7508 || ada_type_name (type) == NULL)
14f9c5c9 7509 return NULL;
d2e4a39e 7510 else
14f9c5c9
AS
7511 {
7512 int len = strlen (ada_type_name (type));
5b4ee69b 7513
4c4b4cd2
PH
7514 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7515 return type;
14f9c5c9 7516 else
4c4b4cd2 7517 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
7518 }
7519}
7520
7521/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 7522 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 7523
d2e4a39e
AS
7524static int
7525is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
7526{
7527 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 7528
d2e4a39e 7529 return name != NULL
14f9c5c9
AS
7530 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
7531 && strstr (name, "___XVL") != NULL;
7532}
7533
4c4b4cd2
PH
7534/* The index of the variant field of TYPE, or -1 if TYPE does not
7535 represent a variant record type. */
14f9c5c9 7536
d2e4a39e 7537static int
4c4b4cd2 7538variant_field_index (struct type *type)
14f9c5c9
AS
7539{
7540 int f;
7541
4c4b4cd2
PH
7542 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
7543 return -1;
7544
7545 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
7546 {
7547 if (ada_is_variant_part (type, f))
7548 return f;
7549 }
7550 return -1;
14f9c5c9
AS
7551}
7552
4c4b4cd2
PH
7553/* A record type with no fields. */
7554
d2e4a39e 7555static struct type *
e9bb382b 7556empty_record (struct type *template)
14f9c5c9 7557{
e9bb382b 7558 struct type *type = alloc_type_copy (template);
5b4ee69b 7559
14f9c5c9
AS
7560 TYPE_CODE (type) = TYPE_CODE_STRUCT;
7561 TYPE_NFIELDS (type) = 0;
7562 TYPE_FIELDS (type) = NULL;
b1f33ddd 7563 INIT_CPLUS_SPECIFIC (type);
14f9c5c9
AS
7564 TYPE_NAME (type) = "<empty>";
7565 TYPE_TAG_NAME (type) = NULL;
14f9c5c9
AS
7566 TYPE_LENGTH (type) = 0;
7567 return type;
7568}
7569
7570/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
7571 the value of type TYPE at VALADDR or ADDRESS (see comments at
7572 the beginning of this section) VAL according to GNAT conventions.
7573 DVAL0 should describe the (portion of a) record that contains any
df407dfe 7574 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
7575 an outer-level type (i.e., as opposed to a branch of a variant.) A
7576 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 7577 of the variant.
14f9c5c9 7578
4c4b4cd2
PH
7579 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7580 length are not statically known are discarded. As a consequence,
7581 VALADDR, ADDRESS and DVAL0 are ignored.
7582
7583 NOTE: Limitations: For now, we assume that dynamic fields and
7584 variants occupy whole numbers of bytes. However, they need not be
7585 byte-aligned. */
7586
7587struct type *
10a2c479 7588ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 7589 const gdb_byte *valaddr,
4c4b4cd2
PH
7590 CORE_ADDR address, struct value *dval0,
7591 int keep_dynamic_fields)
14f9c5c9 7592{
d2e4a39e
AS
7593 struct value *mark = value_mark ();
7594 struct value *dval;
7595 struct type *rtype;
14f9c5c9 7596 int nfields, bit_len;
4c4b4cd2 7597 int variant_field;
14f9c5c9 7598 long off;
d94e4f4f 7599 int fld_bit_len;
14f9c5c9
AS
7600 int f;
7601
4c4b4cd2
PH
7602 /* Compute the number of fields in this record type that are going
7603 to be processed: unless keep_dynamic_fields, this includes only
7604 fields whose position and length are static will be processed. */
7605 if (keep_dynamic_fields)
7606 nfields = TYPE_NFIELDS (type);
7607 else
7608 {
7609 nfields = 0;
76a01679 7610 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
7611 && !ada_is_variant_part (type, nfields)
7612 && !is_dynamic_field (type, nfields))
7613 nfields++;
7614 }
7615
e9bb382b 7616 rtype = alloc_type_copy (type);
14f9c5c9
AS
7617 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7618 INIT_CPLUS_SPECIFIC (rtype);
7619 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 7620 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
7621 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7622 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
7623 TYPE_NAME (rtype) = ada_type_name (type);
7624 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7625 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 7626
d2e4a39e
AS
7627 off = 0;
7628 bit_len = 0;
4c4b4cd2
PH
7629 variant_field = -1;
7630
14f9c5c9
AS
7631 for (f = 0; f < nfields; f += 1)
7632 {
6c038f32
PH
7633 off = align_value (off, field_alignment (type, f))
7634 + TYPE_FIELD_BITPOS (type, f);
945b3a32 7635 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 7636 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 7637
d2e4a39e 7638 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
7639 {
7640 variant_field = f;
d94e4f4f 7641 fld_bit_len = 0;
4c4b4cd2 7642 }
14f9c5c9 7643 else if (is_dynamic_field (type, f))
4c4b4cd2 7644 {
284614f0
JB
7645 const gdb_byte *field_valaddr = valaddr;
7646 CORE_ADDR field_address = address;
7647 struct type *field_type =
7648 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
7649
4c4b4cd2 7650 if (dval0 == NULL)
b5304971
JG
7651 {
7652 /* rtype's length is computed based on the run-time
7653 value of discriminants. If the discriminants are not
7654 initialized, the type size may be completely bogus and
0963b4bd 7655 GDB may fail to allocate a value for it. So check the
b5304971
JG
7656 size first before creating the value. */
7657 check_size (rtype);
7658 dval = value_from_contents_and_address (rtype, valaddr, address);
7659 }
4c4b4cd2
PH
7660 else
7661 dval = dval0;
7662
284614f0
JB
7663 /* If the type referenced by this field is an aligner type, we need
7664 to unwrap that aligner type, because its size might not be set.
7665 Keeping the aligner type would cause us to compute the wrong
7666 size for this field, impacting the offset of the all the fields
7667 that follow this one. */
7668 if (ada_is_aligner_type (field_type))
7669 {
7670 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
7671
7672 field_valaddr = cond_offset_host (field_valaddr, field_offset);
7673 field_address = cond_offset_target (field_address, field_offset);
7674 field_type = ada_aligned_type (field_type);
7675 }
7676
7677 field_valaddr = cond_offset_host (field_valaddr,
7678 off / TARGET_CHAR_BIT);
7679 field_address = cond_offset_target (field_address,
7680 off / TARGET_CHAR_BIT);
7681
7682 /* Get the fixed type of the field. Note that, in this case,
7683 we do not want to get the real type out of the tag: if
7684 the current field is the parent part of a tagged record,
7685 we will get the tag of the object. Clearly wrong: the real
7686 type of the parent is not the real type of the child. We
7687 would end up in an infinite loop. */
7688 field_type = ada_get_base_type (field_type);
7689 field_type = ada_to_fixed_type (field_type, field_valaddr,
7690 field_address, dval, 0);
27f2a97b
JB
7691 /* If the field size is already larger than the maximum
7692 object size, then the record itself will necessarily
7693 be larger than the maximum object size. We need to make
7694 this check now, because the size might be so ridiculously
7695 large (due to an uninitialized variable in the inferior)
7696 that it would cause an overflow when adding it to the
7697 record size. */
7698 check_size (field_type);
284614f0
JB
7699
7700 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 7701 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
7702 /* The multiplication can potentially overflow. But because
7703 the field length has been size-checked just above, and
7704 assuming that the maximum size is a reasonable value,
7705 an overflow should not happen in practice. So rather than
7706 adding overflow recovery code to this already complex code,
7707 we just assume that it's not going to happen. */
d94e4f4f 7708 fld_bit_len =
4c4b4cd2
PH
7709 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
7710 }
14f9c5c9 7711 else
4c4b4cd2 7712 {
5ded5331
JB
7713 /* Note: If this field's type is a typedef, it is important
7714 to preserve the typedef layer.
7715
7716 Otherwise, we might be transforming a typedef to a fat
7717 pointer (encoding a pointer to an unconstrained array),
7718 into a basic fat pointer (encoding an unconstrained
7719 array). As both types are implemented using the same
7720 structure, the typedef is the only clue which allows us
7721 to distinguish between the two options. Stripping it
7722 would prevent us from printing this field appropriately. */
7723 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
7724 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7725 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 7726 fld_bit_len =
4c4b4cd2
PH
7727 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7728 else
5ded5331
JB
7729 {
7730 struct type *field_type = TYPE_FIELD_TYPE (type, f);
7731
7732 /* We need to be careful of typedefs when computing
7733 the length of our field. If this is a typedef,
7734 get the length of the target type, not the length
7735 of the typedef. */
7736 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
7737 field_type = ada_typedef_target_type (field_type);
7738
7739 fld_bit_len =
7740 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7741 }
4c4b4cd2 7742 }
14f9c5c9 7743 if (off + fld_bit_len > bit_len)
4c4b4cd2 7744 bit_len = off + fld_bit_len;
d94e4f4f 7745 off += fld_bit_len;
4c4b4cd2
PH
7746 TYPE_LENGTH (rtype) =
7747 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 7748 }
4c4b4cd2
PH
7749
7750 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 7751 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
7752 the record. This can happen in the presence of representation
7753 clauses. */
7754 if (variant_field >= 0)
7755 {
7756 struct type *branch_type;
7757
7758 off = TYPE_FIELD_BITPOS (rtype, variant_field);
7759
7760 if (dval0 == NULL)
7761 dval = value_from_contents_and_address (rtype, valaddr, address);
7762 else
7763 dval = dval0;
7764
7765 branch_type =
7766 to_fixed_variant_branch_type
7767 (TYPE_FIELD_TYPE (type, variant_field),
7768 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7769 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7770 if (branch_type == NULL)
7771 {
7772 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
7773 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7774 TYPE_NFIELDS (rtype) -= 1;
7775 }
7776 else
7777 {
7778 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7779 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7780 fld_bit_len =
7781 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
7782 TARGET_CHAR_BIT;
7783 if (off + fld_bit_len > bit_len)
7784 bit_len = off + fld_bit_len;
7785 TYPE_LENGTH (rtype) =
7786 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7787 }
7788 }
7789
714e53ab
PH
7790 /* According to exp_dbug.ads, the size of TYPE for variable-size records
7791 should contain the alignment of that record, which should be a strictly
7792 positive value. If null or negative, then something is wrong, most
7793 probably in the debug info. In that case, we don't round up the size
0963b4bd 7794 of the resulting type. If this record is not part of another structure,
714e53ab
PH
7795 the current RTYPE length might be good enough for our purposes. */
7796 if (TYPE_LENGTH (type) <= 0)
7797 {
323e0a4a
AC
7798 if (TYPE_NAME (rtype))
7799 warning (_("Invalid type size for `%s' detected: %d."),
7800 TYPE_NAME (rtype), TYPE_LENGTH (type));
7801 else
7802 warning (_("Invalid type size for <unnamed> detected: %d."),
7803 TYPE_LENGTH (type));
714e53ab
PH
7804 }
7805 else
7806 {
7807 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
7808 TYPE_LENGTH (type));
7809 }
14f9c5c9
AS
7810
7811 value_free_to_mark (mark);
d2e4a39e 7812 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 7813 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
7814 return rtype;
7815}
7816
4c4b4cd2
PH
7817/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7818 of 1. */
14f9c5c9 7819
d2e4a39e 7820static struct type *
fc1a4b47 7821template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
7822 CORE_ADDR address, struct value *dval0)
7823{
7824 return ada_template_to_fixed_record_type_1 (type, valaddr,
7825 address, dval0, 1);
7826}
7827
7828/* An ordinary record type in which ___XVL-convention fields and
7829 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7830 static approximations, containing all possible fields. Uses
7831 no runtime values. Useless for use in values, but that's OK,
7832 since the results are used only for type determinations. Works on both
7833 structs and unions. Representation note: to save space, we memorize
7834 the result of this function in the TYPE_TARGET_TYPE of the
7835 template type. */
7836
7837static struct type *
7838template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
7839{
7840 struct type *type;
7841 int nfields;
7842 int f;
7843
4c4b4cd2
PH
7844 if (TYPE_TARGET_TYPE (type0) != NULL)
7845 return TYPE_TARGET_TYPE (type0);
7846
7847 nfields = TYPE_NFIELDS (type0);
7848 type = type0;
14f9c5c9
AS
7849
7850 for (f = 0; f < nfields; f += 1)
7851 {
61ee279c 7852 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
4c4b4cd2 7853 struct type *new_type;
14f9c5c9 7854
4c4b4cd2
PH
7855 if (is_dynamic_field (type0, f))
7856 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
14f9c5c9 7857 else
f192137b 7858 new_type = static_unwrap_type (field_type);
4c4b4cd2
PH
7859 if (type == type0 && new_type != field_type)
7860 {
e9bb382b 7861 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
4c4b4cd2
PH
7862 TYPE_CODE (type) = TYPE_CODE (type0);
7863 INIT_CPLUS_SPECIFIC (type);
7864 TYPE_NFIELDS (type) = nfields;
7865 TYPE_FIELDS (type) = (struct field *)
7866 TYPE_ALLOC (type, nfields * sizeof (struct field));
7867 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
7868 sizeof (struct field) * nfields);
7869 TYPE_NAME (type) = ada_type_name (type0);
7870 TYPE_TAG_NAME (type) = NULL;
876cecd0 7871 TYPE_FIXED_INSTANCE (type) = 1;
4c4b4cd2
PH
7872 TYPE_LENGTH (type) = 0;
7873 }
7874 TYPE_FIELD_TYPE (type, f) = new_type;
7875 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
14f9c5c9 7876 }
14f9c5c9
AS
7877 return type;
7878}
7879
4c4b4cd2 7880/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
7881 whose address in memory is ADDRESS, returns a revision of TYPE,
7882 which should be a non-dynamic-sized record, in which the variant
7883 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
7884 for discriminant values in DVAL0, which can be NULL if the record
7885 contains the necessary discriminant values. */
7886
d2e4a39e 7887static struct type *
fc1a4b47 7888to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 7889 CORE_ADDR address, struct value *dval0)
14f9c5c9 7890{
d2e4a39e 7891 struct value *mark = value_mark ();
4c4b4cd2 7892 struct value *dval;
d2e4a39e 7893 struct type *rtype;
14f9c5c9
AS
7894 struct type *branch_type;
7895 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 7896 int variant_field = variant_field_index (type);
14f9c5c9 7897
4c4b4cd2 7898 if (variant_field == -1)
14f9c5c9
AS
7899 return type;
7900
4c4b4cd2
PH
7901 if (dval0 == NULL)
7902 dval = value_from_contents_and_address (type, valaddr, address);
7903 else
7904 dval = dval0;
7905
e9bb382b 7906 rtype = alloc_type_copy (type);
14f9c5c9 7907 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
7908 INIT_CPLUS_SPECIFIC (rtype);
7909 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
7910 TYPE_FIELDS (rtype) =
7911 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7912 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 7913 sizeof (struct field) * nfields);
14f9c5c9
AS
7914 TYPE_NAME (rtype) = ada_type_name (type);
7915 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7916 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
7917 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7918
4c4b4cd2
PH
7919 branch_type = to_fixed_variant_branch_type
7920 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 7921 cond_offset_host (valaddr,
4c4b4cd2
PH
7922 TYPE_FIELD_BITPOS (type, variant_field)
7923 / TARGET_CHAR_BIT),
d2e4a39e 7924 cond_offset_target (address,
4c4b4cd2
PH
7925 TYPE_FIELD_BITPOS (type, variant_field)
7926 / TARGET_CHAR_BIT), dval);
d2e4a39e 7927 if (branch_type == NULL)
14f9c5c9 7928 {
4c4b4cd2 7929 int f;
5b4ee69b 7930
4c4b4cd2
PH
7931 for (f = variant_field + 1; f < nfields; f += 1)
7932 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 7933 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
7934 }
7935 else
7936 {
4c4b4cd2
PH
7937 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7938 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7939 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 7940 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 7941 }
4c4b4cd2 7942 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 7943
4c4b4cd2 7944 value_free_to_mark (mark);
14f9c5c9
AS
7945 return rtype;
7946}
7947
7948/* An ordinary record type (with fixed-length fields) that describes
7949 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7950 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
7951 should be in DVAL, a record value; it may be NULL if the object
7952 at ADDR itself contains any necessary discriminant values.
7953 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7954 values from the record are needed. Except in the case that DVAL,
7955 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7956 unchecked) is replaced by a particular branch of the variant.
7957
7958 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7959 is questionable and may be removed. It can arise during the
7960 processing of an unconstrained-array-of-record type where all the
7961 variant branches have exactly the same size. This is because in
7962 such cases, the compiler does not bother to use the XVS convention
7963 when encoding the record. I am currently dubious of this
7964 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 7965
d2e4a39e 7966static struct type *
fc1a4b47 7967to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 7968 CORE_ADDR address, struct value *dval)
14f9c5c9 7969{
d2e4a39e 7970 struct type *templ_type;
14f9c5c9 7971
876cecd0 7972 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
7973 return type0;
7974
d2e4a39e 7975 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
7976
7977 if (templ_type != NULL)
7978 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
7979 else if (variant_field_index (type0) >= 0)
7980 {
7981 if (dval == NULL && valaddr == NULL && address == 0)
7982 return type0;
7983 return to_record_with_fixed_variant_part (type0, valaddr, address,
7984 dval);
7985 }
14f9c5c9
AS
7986 else
7987 {
876cecd0 7988 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
7989 return type0;
7990 }
7991
7992}
7993
7994/* An ordinary record type (with fixed-length fields) that describes
7995 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7996 union type. Any necessary discriminants' values should be in DVAL,
7997 a record value. That is, this routine selects the appropriate
7998 branch of the union at ADDR according to the discriminant value
b1f33ddd 7999 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8000 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8001
d2e4a39e 8002static struct type *
fc1a4b47 8003to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8004 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8005{
8006 int which;
d2e4a39e
AS
8007 struct type *templ_type;
8008 struct type *var_type;
14f9c5c9
AS
8009
8010 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8011 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8012 else
14f9c5c9
AS
8013 var_type = var_type0;
8014
8015 templ_type = ada_find_parallel_type (var_type, "___XVU");
8016
8017 if (templ_type != NULL)
8018 var_type = templ_type;
8019
b1f33ddd
JB
8020 if (is_unchecked_variant (var_type, value_type (dval)))
8021 return var_type0;
d2e4a39e
AS
8022 which =
8023 ada_which_variant_applies (var_type,
0fd88904 8024 value_type (dval), value_contents (dval));
14f9c5c9
AS
8025
8026 if (which < 0)
e9bb382b 8027 return empty_record (var_type);
14f9c5c9 8028 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8029 return to_fixed_record_type
d2e4a39e
AS
8030 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8031 valaddr, address, dval);
4c4b4cd2 8032 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8033 return
8034 to_fixed_record_type
8035 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8036 else
8037 return TYPE_FIELD_TYPE (var_type, which);
8038}
8039
8040/* Assuming that TYPE0 is an array type describing the type of a value
8041 at ADDR, and that DVAL describes a record containing any
8042 discriminants used in TYPE0, returns a type for the value that
8043 contains no dynamic components (that is, no components whose sizes
8044 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8045 true, gives an error message if the resulting type's size is over
4c4b4cd2 8046 varsize_limit. */
14f9c5c9 8047
d2e4a39e
AS
8048static struct type *
8049to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8050 int ignore_too_big)
14f9c5c9 8051{
d2e4a39e
AS
8052 struct type *index_type_desc;
8053 struct type *result;
ad82864c 8054 int constrained_packed_array_p;
14f9c5c9 8055
b0dd7688 8056 type0 = ada_check_typedef (type0);
284614f0 8057 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8058 return type0;
14f9c5c9 8059
ad82864c
JB
8060 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8061 if (constrained_packed_array_p)
8062 type0 = decode_constrained_packed_array_type (type0);
284614f0 8063
14f9c5c9 8064 index_type_desc = ada_find_parallel_type (type0, "___XA");
28c85d6c 8065 ada_fixup_array_indexes_type (index_type_desc);
14f9c5c9
AS
8066 if (index_type_desc == NULL)
8067 {
61ee279c 8068 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8069
14f9c5c9 8070 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8071 depend on the contents of the array in properly constructed
8072 debugging data. */
529cad9c
PH
8073 /* Create a fixed version of the array element type.
8074 We're not providing the address of an element here,
e1d5a0d2 8075 and thus the actual object value cannot be inspected to do
529cad9c
PH
8076 the conversion. This should not be a problem, since arrays of
8077 unconstrained objects are not allowed. In particular, all
8078 the elements of an array of a tagged type should all be of
8079 the same type specified in the debugging info. No need to
8080 consult the object tag. */
1ed6ede0 8081 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8082
284614f0
JB
8083 /* Make sure we always create a new array type when dealing with
8084 packed array types, since we're going to fix-up the array
8085 type length and element bitsize a little further down. */
ad82864c 8086 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8087 result = type0;
14f9c5c9 8088 else
e9bb382b 8089 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8090 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8091 }
8092 else
8093 {
8094 int i;
8095 struct type *elt_type0;
8096
8097 elt_type0 = type0;
8098 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8099 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8100
8101 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8102 depend on the contents of the array in properly constructed
8103 debugging data. */
529cad9c
PH
8104 /* Create a fixed version of the array element type.
8105 We're not providing the address of an element here,
e1d5a0d2 8106 and thus the actual object value cannot be inspected to do
529cad9c
PH
8107 the conversion. This should not be a problem, since arrays of
8108 unconstrained objects are not allowed. In particular, all
8109 the elements of an array of a tagged type should all be of
8110 the same type specified in the debugging info. No need to
8111 consult the object tag. */
1ed6ede0
JB
8112 result =
8113 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8114
8115 elt_type0 = type0;
14f9c5c9 8116 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8117 {
8118 struct type *range_type =
28c85d6c 8119 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8120
e9bb382b 8121 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8122 result, range_type);
1ce677a4 8123 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8124 }
d2e4a39e 8125 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8126 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8127 }
8128
2e6fda7d
JB
8129 /* We want to preserve the type name. This can be useful when
8130 trying to get the type name of a value that has already been
8131 printed (for instance, if the user did "print VAR; whatis $". */
8132 TYPE_NAME (result) = TYPE_NAME (type0);
8133
ad82864c 8134 if (constrained_packed_array_p)
284614f0
JB
8135 {
8136 /* So far, the resulting type has been created as if the original
8137 type was a regular (non-packed) array type. As a result, the
8138 bitsize of the array elements needs to be set again, and the array
8139 length needs to be recomputed based on that bitsize. */
8140 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8141 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8142
8143 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8144 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8145 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8146 TYPE_LENGTH (result)++;
8147 }
8148
876cecd0 8149 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8150 return result;
d2e4a39e 8151}
14f9c5c9
AS
8152
8153
8154/* A standard type (containing no dynamically sized components)
8155 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8156 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8157 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8158 ADDRESS or in VALADDR contains these discriminants.
8159
1ed6ede0
JB
8160 If CHECK_TAG is not null, in the case of tagged types, this function
8161 attempts to locate the object's tag and use it to compute the actual
8162 type. However, when ADDRESS is null, we cannot use it to determine the
8163 location of the tag, and therefore compute the tagged type's actual type.
8164 So we return the tagged type without consulting the tag. */
529cad9c 8165
f192137b
JB
8166static struct type *
8167ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 8168 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 8169{
61ee279c 8170 type = ada_check_typedef (type);
d2e4a39e
AS
8171 switch (TYPE_CODE (type))
8172 {
8173 default:
14f9c5c9 8174 return type;
d2e4a39e 8175 case TYPE_CODE_STRUCT:
4c4b4cd2 8176 {
76a01679 8177 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
8178 struct type *fixed_record_type =
8179 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 8180
529cad9c
PH
8181 /* If STATIC_TYPE is a tagged type and we know the object's address,
8182 then we can determine its tag, and compute the object's actual
0963b4bd 8183 type from there. Note that we have to use the fixed record
1ed6ede0
JB
8184 type (the parent part of the record may have dynamic fields
8185 and the way the location of _tag is expressed may depend on
8186 them). */
529cad9c 8187
1ed6ede0 8188 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 8189 {
b50d69b5
JG
8190 struct value *tag =
8191 value_tag_from_contents_and_address
8192 (fixed_record_type,
8193 valaddr,
8194 address);
8195 struct type *real_type = type_from_tag (tag);
8196 struct value *obj =
8197 value_from_contents_and_address (fixed_record_type,
8198 valaddr,
8199 address);
76a01679 8200 if (real_type != NULL)
b50d69b5
JG
8201 return to_fixed_record_type
8202 (real_type, NULL,
8203 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 8204 }
4af88198
JB
8205
8206 /* Check to see if there is a parallel ___XVZ variable.
8207 If there is, then it provides the actual size of our type. */
8208 else if (ada_type_name (fixed_record_type) != NULL)
8209 {
0d5cff50 8210 const char *name = ada_type_name (fixed_record_type);
4af88198
JB
8211 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
8212 int xvz_found = 0;
8213 LONGEST size;
8214
88c15c34 8215 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
4af88198
JB
8216 size = get_int_var_value (xvz_name, &xvz_found);
8217 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8218 {
8219 fixed_record_type = copy_type (fixed_record_type);
8220 TYPE_LENGTH (fixed_record_type) = size;
8221
8222 /* The FIXED_RECORD_TYPE may have be a stub. We have
8223 observed this when the debugging info is STABS, and
8224 apparently it is something that is hard to fix.
8225
8226 In practice, we don't need the actual type definition
8227 at all, because the presence of the XVZ variable allows us
8228 to assume that there must be a XVS type as well, which we
8229 should be able to use later, when we need the actual type
8230 definition.
8231
8232 In the meantime, pretend that the "fixed" type we are
8233 returning is NOT a stub, because this can cause trouble
8234 when using this type to create new types targeting it.
8235 Indeed, the associated creation routines often check
8236 whether the target type is a stub and will try to replace
0963b4bd 8237 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
8238 might cause the new type to have the wrong size too.
8239 Consider the case of an array, for instance, where the size
8240 of the array is computed from the number of elements in
8241 our array multiplied by the size of its element. */
8242 TYPE_STUB (fixed_record_type) = 0;
8243 }
8244 }
1ed6ede0 8245 return fixed_record_type;
4c4b4cd2 8246 }
d2e4a39e 8247 case TYPE_CODE_ARRAY:
4c4b4cd2 8248 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
8249 case TYPE_CODE_UNION:
8250 if (dval == NULL)
4c4b4cd2 8251 return type;
d2e4a39e 8252 else
4c4b4cd2 8253 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 8254 }
14f9c5c9
AS
8255}
8256
f192137b
JB
8257/* The same as ada_to_fixed_type_1, except that it preserves the type
8258 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
8259
8260 The typedef layer needs be preserved in order to differentiate between
8261 arrays and array pointers when both types are implemented using the same
8262 fat pointer. In the array pointer case, the pointer is encoded as
8263 a typedef of the pointer type. For instance, considering:
8264
8265 type String_Access is access String;
8266 S1 : String_Access := null;
8267
8268 To the debugger, S1 is defined as a typedef of type String. But
8269 to the user, it is a pointer. So if the user tries to print S1,
8270 we should not dereference the array, but print the array address
8271 instead.
8272
8273 If we didn't preserve the typedef layer, we would lose the fact that
8274 the type is to be presented as a pointer (needs de-reference before
8275 being printed). And we would also use the source-level type name. */
f192137b
JB
8276
8277struct type *
8278ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8279 CORE_ADDR address, struct value *dval, int check_tag)
8280
8281{
8282 struct type *fixed_type =
8283 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8284
96dbd2c1
JB
8285 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8286 then preserve the typedef layer.
8287
8288 Implementation note: We can only check the main-type portion of
8289 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8290 from TYPE now returns a type that has the same instance flags
8291 as TYPE. For instance, if TYPE is a "typedef const", and its
8292 target type is a "struct", then the typedef elimination will return
8293 a "const" version of the target type. See check_typedef for more
8294 details about how the typedef layer elimination is done.
8295
8296 brobecker/2010-11-19: It seems to me that the only case where it is
8297 useful to preserve the typedef layer is when dealing with fat pointers.
8298 Perhaps, we could add a check for that and preserve the typedef layer
8299 only in that situation. But this seems unecessary so far, probably
8300 because we call check_typedef/ada_check_typedef pretty much everywhere.
8301 */
f192137b 8302 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 8303 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 8304 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
8305 return type;
8306
8307 return fixed_type;
8308}
8309
14f9c5c9 8310/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 8311 TYPE0, but based on no runtime data. */
14f9c5c9 8312
d2e4a39e
AS
8313static struct type *
8314to_static_fixed_type (struct type *type0)
14f9c5c9 8315{
d2e4a39e 8316 struct type *type;
14f9c5c9
AS
8317
8318 if (type0 == NULL)
8319 return NULL;
8320
876cecd0 8321 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8322 return type0;
8323
61ee279c 8324 type0 = ada_check_typedef (type0);
d2e4a39e 8325
14f9c5c9
AS
8326 switch (TYPE_CODE (type0))
8327 {
8328 default:
8329 return type0;
8330 case TYPE_CODE_STRUCT:
8331 type = dynamic_template_type (type0);
d2e4a39e 8332 if (type != NULL)
4c4b4cd2
PH
8333 return template_to_static_fixed_type (type);
8334 else
8335 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8336 case TYPE_CODE_UNION:
8337 type = ada_find_parallel_type (type0, "___XVU");
8338 if (type != NULL)
4c4b4cd2
PH
8339 return template_to_static_fixed_type (type);
8340 else
8341 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8342 }
8343}
8344
4c4b4cd2
PH
8345/* A static approximation of TYPE with all type wrappers removed. */
8346
d2e4a39e
AS
8347static struct type *
8348static_unwrap_type (struct type *type)
14f9c5c9
AS
8349{
8350 if (ada_is_aligner_type (type))
8351 {
61ee279c 8352 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 8353 if (ada_type_name (type1) == NULL)
4c4b4cd2 8354 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
8355
8356 return static_unwrap_type (type1);
8357 }
d2e4a39e 8358 else
14f9c5c9 8359 {
d2e4a39e 8360 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 8361
d2e4a39e 8362 if (raw_real_type == type)
4c4b4cd2 8363 return type;
14f9c5c9 8364 else
4c4b4cd2 8365 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
8366 }
8367}
8368
8369/* In some cases, incomplete and private types require
4c4b4cd2 8370 cross-references that are not resolved as records (for example,
14f9c5c9
AS
8371 type Foo;
8372 type FooP is access Foo;
8373 V: FooP;
8374 type Foo is array ...;
4c4b4cd2 8375 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
8376 cross-references to such types, we instead substitute for FooP a
8377 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 8378 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
8379
8380/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
8381 exists, otherwise TYPE. */
8382
d2e4a39e 8383struct type *
61ee279c 8384ada_check_typedef (struct type *type)
14f9c5c9 8385{
727e3d2e
JB
8386 if (type == NULL)
8387 return NULL;
8388
720d1a40
JB
8389 /* If our type is a typedef type of a fat pointer, then we're done.
8390 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8391 what allows us to distinguish between fat pointers that represent
8392 array types, and fat pointers that represent array access types
8393 (in both cases, the compiler implements them as fat pointers). */
8394 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8395 && is_thick_pntr (ada_typedef_target_type (type)))
8396 return type;
8397
14f9c5c9
AS
8398 CHECK_TYPEDEF (type);
8399 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 8400 || !TYPE_STUB (type)
14f9c5c9
AS
8401 || TYPE_TAG_NAME (type) == NULL)
8402 return type;
d2e4a39e 8403 else
14f9c5c9 8404 {
0d5cff50 8405 const char *name = TYPE_TAG_NAME (type);
d2e4a39e 8406 struct type *type1 = ada_find_any_type (name);
5b4ee69b 8407
05e522ef
JB
8408 if (type1 == NULL)
8409 return type;
8410
8411 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8412 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
8413 types, only for the typedef-to-array types). If that's the case,
8414 strip the typedef layer. */
8415 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
8416 type1 = ada_check_typedef (type1);
8417
8418 return type1;
14f9c5c9
AS
8419 }
8420}
8421
8422/* A value representing the data at VALADDR/ADDRESS as described by
8423 type TYPE0, but with a standard (static-sized) type that correctly
8424 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8425 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 8426 creation of struct values]. */
14f9c5c9 8427
4c4b4cd2
PH
8428static struct value *
8429ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8430 struct value *val0)
14f9c5c9 8431{
1ed6ede0 8432 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 8433
14f9c5c9
AS
8434 if (type == type0 && val0 != NULL)
8435 return val0;
d2e4a39e 8436 else
4c4b4cd2
PH
8437 return value_from_contents_and_address (type, 0, address);
8438}
8439
8440/* A value representing VAL, but with a standard (static-sized) type
8441 that correctly describes it. Does not necessarily create a new
8442 value. */
8443
0c3acc09 8444struct value *
4c4b4cd2
PH
8445ada_to_fixed_value (struct value *val)
8446{
c48db5ca
JB
8447 val = unwrap_value (val);
8448 val = ada_to_fixed_value_create (value_type (val),
8449 value_address (val),
8450 val);
8451 return val;
14f9c5c9 8452}
d2e4a39e 8453\f
14f9c5c9 8454
14f9c5c9
AS
8455/* Attributes */
8456
4c4b4cd2
PH
8457/* Table mapping attribute numbers to names.
8458 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 8459
d2e4a39e 8460static const char *attribute_names[] = {
14f9c5c9
AS
8461 "<?>",
8462
d2e4a39e 8463 "first",
14f9c5c9
AS
8464 "last",
8465 "length",
8466 "image",
14f9c5c9
AS
8467 "max",
8468 "min",
4c4b4cd2
PH
8469 "modulus",
8470 "pos",
8471 "size",
8472 "tag",
14f9c5c9 8473 "val",
14f9c5c9
AS
8474 0
8475};
8476
d2e4a39e 8477const char *
4c4b4cd2 8478ada_attribute_name (enum exp_opcode n)
14f9c5c9 8479{
4c4b4cd2
PH
8480 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8481 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
8482 else
8483 return attribute_names[0];
8484}
8485
4c4b4cd2 8486/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 8487
4c4b4cd2
PH
8488static LONGEST
8489pos_atr (struct value *arg)
14f9c5c9 8490{
24209737
PH
8491 struct value *val = coerce_ref (arg);
8492 struct type *type = value_type (val);
14f9c5c9 8493
d2e4a39e 8494 if (!discrete_type_p (type))
323e0a4a 8495 error (_("'POS only defined on discrete types"));
14f9c5c9
AS
8496
8497 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8498 {
8499 int i;
24209737 8500 LONGEST v = value_as_long (val);
14f9c5c9 8501
d2e4a39e 8502 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2 8503 {
14e75d8e 8504 if (v == TYPE_FIELD_ENUMVAL (type, i))
4c4b4cd2
PH
8505 return i;
8506 }
323e0a4a 8507 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9
AS
8508 }
8509 else
24209737 8510 return value_as_long (val);
4c4b4cd2
PH
8511}
8512
8513static struct value *
3cb382c9 8514value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 8515{
3cb382c9 8516 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
8517}
8518
4c4b4cd2 8519/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 8520
d2e4a39e
AS
8521static struct value *
8522value_val_atr (struct type *type, struct value *arg)
14f9c5c9 8523{
d2e4a39e 8524 if (!discrete_type_p (type))
323e0a4a 8525 error (_("'VAL only defined on discrete types"));
df407dfe 8526 if (!integer_type_p (value_type (arg)))
323e0a4a 8527 error (_("'VAL requires integral argument"));
14f9c5c9
AS
8528
8529 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8530 {
8531 long pos = value_as_long (arg);
5b4ee69b 8532
14f9c5c9 8533 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 8534 error (_("argument to 'VAL out of range"));
14e75d8e 8535 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
8536 }
8537 else
8538 return value_from_longest (type, value_as_long (arg));
8539}
14f9c5c9 8540\f
d2e4a39e 8541
4c4b4cd2 8542 /* Evaluation */
14f9c5c9 8543
4c4b4cd2
PH
8544/* True if TYPE appears to be an Ada character type.
8545 [At the moment, this is true only for Character and Wide_Character;
8546 It is a heuristic test that could stand improvement]. */
14f9c5c9 8547
d2e4a39e
AS
8548int
8549ada_is_character_type (struct type *type)
14f9c5c9 8550{
7b9f71f2
JB
8551 const char *name;
8552
8553 /* If the type code says it's a character, then assume it really is,
8554 and don't check any further. */
8555 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
8556 return 1;
8557
8558 /* Otherwise, assume it's a character type iff it is a discrete type
8559 with a known character type name. */
8560 name = ada_type_name (type);
8561 return (name != NULL
8562 && (TYPE_CODE (type) == TYPE_CODE_INT
8563 || TYPE_CODE (type) == TYPE_CODE_RANGE)
8564 && (strcmp (name, "character") == 0
8565 || strcmp (name, "wide_character") == 0
5a517ebd 8566 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 8567 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
8568}
8569
4c4b4cd2 8570/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
8571
8572int
ebf56fd3 8573ada_is_string_type (struct type *type)
14f9c5c9 8574{
61ee279c 8575 type = ada_check_typedef (type);
d2e4a39e 8576 if (type != NULL
14f9c5c9 8577 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
8578 && (ada_is_simple_array_type (type)
8579 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
8580 && ada_array_arity (type) == 1)
8581 {
8582 struct type *elttype = ada_array_element_type (type, 1);
8583
8584 return ada_is_character_type (elttype);
8585 }
d2e4a39e 8586 else
14f9c5c9
AS
8587 return 0;
8588}
8589
5bf03f13
JB
8590/* The compiler sometimes provides a parallel XVS type for a given
8591 PAD type. Normally, it is safe to follow the PAD type directly,
8592 but older versions of the compiler have a bug that causes the offset
8593 of its "F" field to be wrong. Following that field in that case
8594 would lead to incorrect results, but this can be worked around
8595 by ignoring the PAD type and using the associated XVS type instead.
8596
8597 Set to True if the debugger should trust the contents of PAD types.
8598 Otherwise, ignore the PAD type if there is a parallel XVS type. */
8599static int trust_pad_over_xvs = 1;
14f9c5c9
AS
8600
8601/* True if TYPE is a struct type introduced by the compiler to force the
8602 alignment of a value. Such types have a single field with a
4c4b4cd2 8603 distinctive name. */
14f9c5c9
AS
8604
8605int
ebf56fd3 8606ada_is_aligner_type (struct type *type)
14f9c5c9 8607{
61ee279c 8608 type = ada_check_typedef (type);
714e53ab 8609
5bf03f13 8610 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
8611 return 0;
8612
14f9c5c9 8613 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
8614 && TYPE_NFIELDS (type) == 1
8615 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
8616}
8617
8618/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 8619 the parallel type. */
14f9c5c9 8620
d2e4a39e
AS
8621struct type *
8622ada_get_base_type (struct type *raw_type)
14f9c5c9 8623{
d2e4a39e
AS
8624 struct type *real_type_namer;
8625 struct type *raw_real_type;
14f9c5c9
AS
8626
8627 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
8628 return raw_type;
8629
284614f0
JB
8630 if (ada_is_aligner_type (raw_type))
8631 /* The encoding specifies that we should always use the aligner type.
8632 So, even if this aligner type has an associated XVS type, we should
8633 simply ignore it.
8634
8635 According to the compiler gurus, an XVS type parallel to an aligner
8636 type may exist because of a stabs limitation. In stabs, aligner
8637 types are empty because the field has a variable-sized type, and
8638 thus cannot actually be used as an aligner type. As a result,
8639 we need the associated parallel XVS type to decode the type.
8640 Since the policy in the compiler is to not change the internal
8641 representation based on the debugging info format, we sometimes
8642 end up having a redundant XVS type parallel to the aligner type. */
8643 return raw_type;
8644
14f9c5c9 8645 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 8646 if (real_type_namer == NULL
14f9c5c9
AS
8647 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
8648 || TYPE_NFIELDS (real_type_namer) != 1)
8649 return raw_type;
8650
f80d3ff2
JB
8651 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
8652 {
8653 /* This is an older encoding form where the base type needs to be
8654 looked up by name. We prefer the newer enconding because it is
8655 more efficient. */
8656 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
8657 if (raw_real_type == NULL)
8658 return raw_type;
8659 else
8660 return raw_real_type;
8661 }
8662
8663 /* The field in our XVS type is a reference to the base type. */
8664 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 8665}
14f9c5c9 8666
4c4b4cd2 8667/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 8668
d2e4a39e
AS
8669struct type *
8670ada_aligned_type (struct type *type)
14f9c5c9
AS
8671{
8672 if (ada_is_aligner_type (type))
8673 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
8674 else
8675 return ada_get_base_type (type);
8676}
8677
8678
8679/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 8680 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 8681
fc1a4b47
AC
8682const gdb_byte *
8683ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 8684{
d2e4a39e 8685 if (ada_is_aligner_type (type))
14f9c5c9 8686 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
8687 valaddr +
8688 TYPE_FIELD_BITPOS (type,
8689 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
8690 else
8691 return valaddr;
8692}
8693
4c4b4cd2
PH
8694
8695
14f9c5c9 8696/* The printed representation of an enumeration literal with encoded
4c4b4cd2 8697 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
8698const char *
8699ada_enum_name (const char *name)
14f9c5c9 8700{
4c4b4cd2
PH
8701 static char *result;
8702 static size_t result_len = 0;
d2e4a39e 8703 char *tmp;
14f9c5c9 8704
4c4b4cd2
PH
8705 /* First, unqualify the enumeration name:
8706 1. Search for the last '.' character. If we find one, then skip
177b42fe 8707 all the preceding characters, the unqualified name starts
76a01679 8708 right after that dot.
4c4b4cd2 8709 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
8710 translates dots into "__". Search forward for double underscores,
8711 but stop searching when we hit an overloading suffix, which is
8712 of the form "__" followed by digits. */
4c4b4cd2 8713
c3e5cd34
PH
8714 tmp = strrchr (name, '.');
8715 if (tmp != NULL)
4c4b4cd2
PH
8716 name = tmp + 1;
8717 else
14f9c5c9 8718 {
4c4b4cd2
PH
8719 while ((tmp = strstr (name, "__")) != NULL)
8720 {
8721 if (isdigit (tmp[2]))
8722 break;
8723 else
8724 name = tmp + 2;
8725 }
14f9c5c9
AS
8726 }
8727
8728 if (name[0] == 'Q')
8729 {
14f9c5c9 8730 int v;
5b4ee69b 8731
14f9c5c9 8732 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
8733 {
8734 if (sscanf (name + 2, "%x", &v) != 1)
8735 return name;
8736 }
14f9c5c9 8737 else
4c4b4cd2 8738 return name;
14f9c5c9 8739
4c4b4cd2 8740 GROW_VECT (result, result_len, 16);
14f9c5c9 8741 if (isascii (v) && isprint (v))
88c15c34 8742 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 8743 else if (name[1] == 'U')
88c15c34 8744 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 8745 else
88c15c34 8746 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
8747
8748 return result;
8749 }
d2e4a39e 8750 else
4c4b4cd2 8751 {
c3e5cd34
PH
8752 tmp = strstr (name, "__");
8753 if (tmp == NULL)
8754 tmp = strstr (name, "$");
8755 if (tmp != NULL)
4c4b4cd2
PH
8756 {
8757 GROW_VECT (result, result_len, tmp - name + 1);
8758 strncpy (result, name, tmp - name);
8759 result[tmp - name] = '\0';
8760 return result;
8761 }
8762
8763 return name;
8764 }
14f9c5c9
AS
8765}
8766
14f9c5c9
AS
8767/* Evaluate the subexpression of EXP starting at *POS as for
8768 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 8769 expression. */
14f9c5c9 8770
d2e4a39e
AS
8771static struct value *
8772evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 8773{
4b27a620 8774 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
8775}
8776
8777/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 8778 value it wraps. */
14f9c5c9 8779
d2e4a39e
AS
8780static struct value *
8781unwrap_value (struct value *val)
14f9c5c9 8782{
df407dfe 8783 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 8784
14f9c5c9
AS
8785 if (ada_is_aligner_type (type))
8786 {
de4d072f 8787 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 8788 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 8789
14f9c5c9 8790 if (ada_type_name (val_type) == NULL)
4c4b4cd2 8791 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
8792
8793 return unwrap_value (v);
8794 }
d2e4a39e 8795 else
14f9c5c9 8796 {
d2e4a39e 8797 struct type *raw_real_type =
61ee279c 8798 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 8799
5bf03f13
JB
8800 /* If there is no parallel XVS or XVE type, then the value is
8801 already unwrapped. Return it without further modification. */
8802 if ((type == raw_real_type)
8803 && ada_find_parallel_type (type, "___XVE") == NULL)
8804 return val;
14f9c5c9 8805
d2e4a39e 8806 return
4c4b4cd2
PH
8807 coerce_unspec_val_to_type
8808 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 8809 value_address (val),
1ed6ede0 8810 NULL, 1));
14f9c5c9
AS
8811 }
8812}
d2e4a39e
AS
8813
8814static struct value *
8815cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
8816{
8817 LONGEST val;
8818
df407dfe 8819 if (type == value_type (arg))
14f9c5c9 8820 return arg;
df407dfe 8821 else if (ada_is_fixed_point_type (value_type (arg)))
d2e4a39e 8822 val = ada_float_to_fixed (type,
df407dfe 8823 ada_fixed_to_float (value_type (arg),
4c4b4cd2 8824 value_as_long (arg)));
d2e4a39e 8825 else
14f9c5c9 8826 {
a53b7a21 8827 DOUBLEST argd = value_as_double (arg);
5b4ee69b 8828
14f9c5c9
AS
8829 val = ada_float_to_fixed (type, argd);
8830 }
8831
8832 return value_from_longest (type, val);
8833}
8834
d2e4a39e 8835static struct value *
a53b7a21 8836cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 8837{
df407dfe 8838 DOUBLEST val = ada_fixed_to_float (value_type (arg),
4c4b4cd2 8839 value_as_long (arg));
5b4ee69b 8840
a53b7a21 8841 return value_from_double (type, val);
14f9c5c9
AS
8842}
8843
d99dcf51
JB
8844/* Given two array types T1 and T2, return nonzero iff both arrays
8845 contain the same number of elements. */
8846
8847static int
8848ada_same_array_size_p (struct type *t1, struct type *t2)
8849{
8850 LONGEST lo1, hi1, lo2, hi2;
8851
8852 /* Get the array bounds in order to verify that the size of
8853 the two arrays match. */
8854 if (!get_array_bounds (t1, &lo1, &hi1)
8855 || !get_array_bounds (t2, &lo2, &hi2))
8856 error (_("unable to determine array bounds"));
8857
8858 /* To make things easier for size comparison, normalize a bit
8859 the case of empty arrays by making sure that the difference
8860 between upper bound and lower bound is always -1. */
8861 if (lo1 > hi1)
8862 hi1 = lo1 - 1;
8863 if (lo2 > hi2)
8864 hi2 = lo2 - 1;
8865
8866 return (hi1 - lo1 == hi2 - lo2);
8867}
8868
8869/* Assuming that VAL is an array of integrals, and TYPE represents
8870 an array with the same number of elements, but with wider integral
8871 elements, return an array "casted" to TYPE. In practice, this
8872 means that the returned array is built by casting each element
8873 of the original array into TYPE's (wider) element type. */
8874
8875static struct value *
8876ada_promote_array_of_integrals (struct type *type, struct value *val)
8877{
8878 struct type *elt_type = TYPE_TARGET_TYPE (type);
8879 LONGEST lo, hi;
8880 struct value *res;
8881 LONGEST i;
8882
8883 /* Verify that both val and type are arrays of scalars, and
8884 that the size of val's elements is smaller than the size
8885 of type's element. */
8886 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
8887 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
8888 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
8889 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
8890 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
8891 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
8892
8893 if (!get_array_bounds (type, &lo, &hi))
8894 error (_("unable to determine array bounds"));
8895
8896 res = allocate_value (type);
8897
8898 /* Promote each array element. */
8899 for (i = 0; i < hi - lo + 1; i++)
8900 {
8901 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
8902
8903 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
8904 value_contents_all (elt), TYPE_LENGTH (elt_type));
8905 }
8906
8907 return res;
8908}
8909
4c4b4cd2
PH
8910/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8911 return the converted value. */
8912
d2e4a39e
AS
8913static struct value *
8914coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 8915{
df407dfe 8916 struct type *type2 = value_type (val);
5b4ee69b 8917
14f9c5c9
AS
8918 if (type == type2)
8919 return val;
8920
61ee279c
PH
8921 type2 = ada_check_typedef (type2);
8922 type = ada_check_typedef (type);
14f9c5c9 8923
d2e4a39e
AS
8924 if (TYPE_CODE (type2) == TYPE_CODE_PTR
8925 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
8926 {
8927 val = ada_value_ind (val);
df407dfe 8928 type2 = value_type (val);
14f9c5c9
AS
8929 }
8930
d2e4a39e 8931 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
8932 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
8933 {
d99dcf51
JB
8934 if (!ada_same_array_size_p (type, type2))
8935 error (_("cannot assign arrays of different length"));
8936
8937 if (is_integral_type (TYPE_TARGET_TYPE (type))
8938 && is_integral_type (TYPE_TARGET_TYPE (type2))
8939 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8940 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8941 {
8942 /* Allow implicit promotion of the array elements to
8943 a wider type. */
8944 return ada_promote_array_of_integrals (type, val);
8945 }
8946
8947 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8948 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 8949 error (_("Incompatible types in assignment"));
04624583 8950 deprecated_set_value_type (val, type);
14f9c5c9 8951 }
d2e4a39e 8952 return val;
14f9c5c9
AS
8953}
8954
4c4b4cd2
PH
8955static struct value *
8956ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
8957{
8958 struct value *val;
8959 struct type *type1, *type2;
8960 LONGEST v, v1, v2;
8961
994b9211
AC
8962 arg1 = coerce_ref (arg1);
8963 arg2 = coerce_ref (arg2);
18af8284
JB
8964 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
8965 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 8966
76a01679
JB
8967 if (TYPE_CODE (type1) != TYPE_CODE_INT
8968 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
8969 return value_binop (arg1, arg2, op);
8970
76a01679 8971 switch (op)
4c4b4cd2
PH
8972 {
8973 case BINOP_MOD:
8974 case BINOP_DIV:
8975 case BINOP_REM:
8976 break;
8977 default:
8978 return value_binop (arg1, arg2, op);
8979 }
8980
8981 v2 = value_as_long (arg2);
8982 if (v2 == 0)
323e0a4a 8983 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
8984
8985 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
8986 return value_binop (arg1, arg2, op);
8987
8988 v1 = value_as_long (arg1);
8989 switch (op)
8990 {
8991 case BINOP_DIV:
8992 v = v1 / v2;
76a01679
JB
8993 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
8994 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
8995 break;
8996 case BINOP_REM:
8997 v = v1 % v2;
76a01679
JB
8998 if (v * v1 < 0)
8999 v -= v2;
4c4b4cd2
PH
9000 break;
9001 default:
9002 /* Should not reach this point. */
9003 v = 0;
9004 }
9005
9006 val = allocate_value (type1);
990a07ab 9007 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9008 TYPE_LENGTH (value_type (val)),
9009 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9010 return val;
9011}
9012
9013static int
9014ada_value_equal (struct value *arg1, struct value *arg2)
9015{
df407dfe
AC
9016 if (ada_is_direct_array_type (value_type (arg1))
9017 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9018 {
f58b38bf
JB
9019 /* Automatically dereference any array reference before
9020 we attempt to perform the comparison. */
9021 arg1 = ada_coerce_ref (arg1);
9022 arg2 = ada_coerce_ref (arg2);
9023
4c4b4cd2
PH
9024 arg1 = ada_coerce_to_simple_array (arg1);
9025 arg2 = ada_coerce_to_simple_array (arg2);
df407dfe
AC
9026 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
9027 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
323e0a4a 9028 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9029 /* FIXME: The following works only for types whose
76a01679
JB
9030 representations use all bits (no padding or undefined bits)
9031 and do not have user-defined equality. */
9032 return
df407dfe 9033 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
0fd88904 9034 && memcmp (value_contents (arg1), value_contents (arg2),
df407dfe 9035 TYPE_LENGTH (value_type (arg1))) == 0;
4c4b4cd2
PH
9036 }
9037 return value_equal (arg1, arg2);
9038}
9039
52ce6436
PH
9040/* Total number of component associations in the aggregate starting at
9041 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9042 OP_AGGREGATE. */
52ce6436
PH
9043
9044static int
9045num_component_specs (struct expression *exp, int pc)
9046{
9047 int n, m, i;
5b4ee69b 9048
52ce6436
PH
9049 m = exp->elts[pc + 1].longconst;
9050 pc += 3;
9051 n = 0;
9052 for (i = 0; i < m; i += 1)
9053 {
9054 switch (exp->elts[pc].opcode)
9055 {
9056 default:
9057 n += 1;
9058 break;
9059 case OP_CHOICES:
9060 n += exp->elts[pc + 1].longconst;
9061 break;
9062 }
9063 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9064 }
9065 return n;
9066}
9067
9068/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9069 component of LHS (a simple array or a record), updating *POS past
9070 the expression, assuming that LHS is contained in CONTAINER. Does
9071 not modify the inferior's memory, nor does it modify LHS (unless
9072 LHS == CONTAINER). */
9073
9074static void
9075assign_component (struct value *container, struct value *lhs, LONGEST index,
9076 struct expression *exp, int *pos)
9077{
9078 struct value *mark = value_mark ();
9079 struct value *elt;
5b4ee69b 9080
52ce6436
PH
9081 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
9082 {
22601c15
UW
9083 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9084 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9085
52ce6436
PH
9086 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9087 }
9088 else
9089 {
9090 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9091 elt = ada_to_fixed_value (elt);
52ce6436
PH
9092 }
9093
9094 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9095 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9096 else
9097 value_assign_to_component (container, elt,
9098 ada_evaluate_subexp (NULL, exp, pos,
9099 EVAL_NORMAL));
9100
9101 value_free_to_mark (mark);
9102}
9103
9104/* Assuming that LHS represents an lvalue having a record or array
9105 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9106 of that aggregate's value to LHS, advancing *POS past the
9107 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9108 lvalue containing LHS (possibly LHS itself). Does not modify
9109 the inferior's memory, nor does it modify the contents of
0963b4bd 9110 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9111
9112static struct value *
9113assign_aggregate (struct value *container,
9114 struct value *lhs, struct expression *exp,
9115 int *pos, enum noside noside)
9116{
9117 struct type *lhs_type;
9118 int n = exp->elts[*pos+1].longconst;
9119 LONGEST low_index, high_index;
9120 int num_specs;
9121 LONGEST *indices;
9122 int max_indices, num_indices;
52ce6436 9123 int i;
52ce6436
PH
9124
9125 *pos += 3;
9126 if (noside != EVAL_NORMAL)
9127 {
52ce6436
PH
9128 for (i = 0; i < n; i += 1)
9129 ada_evaluate_subexp (NULL, exp, pos, noside);
9130 return container;
9131 }
9132
9133 container = ada_coerce_ref (container);
9134 if (ada_is_direct_array_type (value_type (container)))
9135 container = ada_coerce_to_simple_array (container);
9136 lhs = ada_coerce_ref (lhs);
9137 if (!deprecated_value_modifiable (lhs))
9138 error (_("Left operand of assignment is not a modifiable lvalue."));
9139
9140 lhs_type = value_type (lhs);
9141 if (ada_is_direct_array_type (lhs_type))
9142 {
9143 lhs = ada_coerce_to_simple_array (lhs);
9144 lhs_type = value_type (lhs);
9145 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9146 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
9147 }
9148 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9149 {
9150 low_index = 0;
9151 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
9152 }
9153 else
9154 error (_("Left-hand side must be array or record."));
9155
9156 num_specs = num_component_specs (exp, *pos - 3);
9157 max_indices = 4 * num_specs + 4;
9158 indices = alloca (max_indices * sizeof (indices[0]));
9159 indices[0] = indices[1] = low_index - 1;
9160 indices[2] = indices[3] = high_index + 1;
9161 num_indices = 4;
9162
9163 for (i = 0; i < n; i += 1)
9164 {
9165 switch (exp->elts[*pos].opcode)
9166 {
1fbf5ada
JB
9167 case OP_CHOICES:
9168 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9169 &num_indices, max_indices,
9170 low_index, high_index);
9171 break;
9172 case OP_POSITIONAL:
9173 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
9174 &num_indices, max_indices,
9175 low_index, high_index);
1fbf5ada
JB
9176 break;
9177 case OP_OTHERS:
9178 if (i != n-1)
9179 error (_("Misplaced 'others' clause"));
9180 aggregate_assign_others (container, lhs, exp, pos, indices,
9181 num_indices, low_index, high_index);
9182 break;
9183 default:
9184 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
9185 }
9186 }
9187
9188 return container;
9189}
9190
9191/* Assign into the component of LHS indexed by the OP_POSITIONAL
9192 construct at *POS, updating *POS past the construct, given that
9193 the positions are relative to lower bound LOW, where HIGH is the
9194 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9195 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 9196 assign_aggregate. */
52ce6436
PH
9197static void
9198aggregate_assign_positional (struct value *container,
9199 struct value *lhs, struct expression *exp,
9200 int *pos, LONGEST *indices, int *num_indices,
9201 int max_indices, LONGEST low, LONGEST high)
9202{
9203 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9204
9205 if (ind - 1 == high)
e1d5a0d2 9206 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
9207 if (ind <= high)
9208 {
9209 add_component_interval (ind, ind, indices, num_indices, max_indices);
9210 *pos += 3;
9211 assign_component (container, lhs, ind, exp, pos);
9212 }
9213 else
9214 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9215}
9216
9217/* Assign into the components of LHS indexed by the OP_CHOICES
9218 construct at *POS, updating *POS past the construct, given that
9219 the allowable indices are LOW..HIGH. Record the indices assigned
9220 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 9221 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9222static void
9223aggregate_assign_from_choices (struct value *container,
9224 struct value *lhs, struct expression *exp,
9225 int *pos, LONGEST *indices, int *num_indices,
9226 int max_indices, LONGEST low, LONGEST high)
9227{
9228 int j;
9229 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9230 int choice_pos, expr_pc;
9231 int is_array = ada_is_direct_array_type (value_type (lhs));
9232
9233 choice_pos = *pos += 3;
9234
9235 for (j = 0; j < n_choices; j += 1)
9236 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9237 expr_pc = *pos;
9238 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9239
9240 for (j = 0; j < n_choices; j += 1)
9241 {
9242 LONGEST lower, upper;
9243 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 9244
52ce6436
PH
9245 if (op == OP_DISCRETE_RANGE)
9246 {
9247 choice_pos += 1;
9248 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9249 EVAL_NORMAL));
9250 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9251 EVAL_NORMAL));
9252 }
9253 else if (is_array)
9254 {
9255 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9256 EVAL_NORMAL));
9257 upper = lower;
9258 }
9259 else
9260 {
9261 int ind;
0d5cff50 9262 const char *name;
5b4ee69b 9263
52ce6436
PH
9264 switch (op)
9265 {
9266 case OP_NAME:
9267 name = &exp->elts[choice_pos + 2].string;
9268 break;
9269 case OP_VAR_VALUE:
9270 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9271 break;
9272 default:
9273 error (_("Invalid record component association."));
9274 }
9275 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9276 ind = 0;
9277 if (! find_struct_field (name, value_type (lhs), 0,
9278 NULL, NULL, NULL, NULL, &ind))
9279 error (_("Unknown component name: %s."), name);
9280 lower = upper = ind;
9281 }
9282
9283 if (lower <= upper && (lower < low || upper > high))
9284 error (_("Index in component association out of bounds."));
9285
9286 add_component_interval (lower, upper, indices, num_indices,
9287 max_indices);
9288 while (lower <= upper)
9289 {
9290 int pos1;
5b4ee69b 9291
52ce6436
PH
9292 pos1 = expr_pc;
9293 assign_component (container, lhs, lower, exp, &pos1);
9294 lower += 1;
9295 }
9296 }
9297}
9298
9299/* Assign the value of the expression in the OP_OTHERS construct in
9300 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9301 have not been previously assigned. The index intervals already assigned
9302 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 9303 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9304static void
9305aggregate_assign_others (struct value *container,
9306 struct value *lhs, struct expression *exp,
9307 int *pos, LONGEST *indices, int num_indices,
9308 LONGEST low, LONGEST high)
9309{
9310 int i;
5ce64950 9311 int expr_pc = *pos + 1;
52ce6436
PH
9312
9313 for (i = 0; i < num_indices - 2; i += 2)
9314 {
9315 LONGEST ind;
5b4ee69b 9316
52ce6436
PH
9317 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9318 {
5ce64950 9319 int localpos;
5b4ee69b 9320
5ce64950
MS
9321 localpos = expr_pc;
9322 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
9323 }
9324 }
9325 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9326}
9327
9328/* Add the interval [LOW .. HIGH] to the sorted set of intervals
9329 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9330 modifying *SIZE as needed. It is an error if *SIZE exceeds
9331 MAX_SIZE. The resulting intervals do not overlap. */
9332static void
9333add_component_interval (LONGEST low, LONGEST high,
9334 LONGEST* indices, int *size, int max_size)
9335{
9336 int i, j;
5b4ee69b 9337
52ce6436
PH
9338 for (i = 0; i < *size; i += 2) {
9339 if (high >= indices[i] && low <= indices[i + 1])
9340 {
9341 int kh;
5b4ee69b 9342
52ce6436
PH
9343 for (kh = i + 2; kh < *size; kh += 2)
9344 if (high < indices[kh])
9345 break;
9346 if (low < indices[i])
9347 indices[i] = low;
9348 indices[i + 1] = indices[kh - 1];
9349 if (high > indices[i + 1])
9350 indices[i + 1] = high;
9351 memcpy (indices + i + 2, indices + kh, *size - kh);
9352 *size -= kh - i - 2;
9353 return;
9354 }
9355 else if (high < indices[i])
9356 break;
9357 }
9358
9359 if (*size == max_size)
9360 error (_("Internal error: miscounted aggregate components."));
9361 *size += 2;
9362 for (j = *size-1; j >= i+2; j -= 1)
9363 indices[j] = indices[j - 2];
9364 indices[i] = low;
9365 indices[i + 1] = high;
9366}
9367
6e48bd2c
JB
9368/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9369 is different. */
9370
9371static struct value *
9372ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
9373{
9374 if (type == ada_check_typedef (value_type (arg2)))
9375 return arg2;
9376
9377 if (ada_is_fixed_point_type (type))
9378 return (cast_to_fixed (type, arg2));
9379
9380 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9381 return cast_from_fixed (type, arg2);
6e48bd2c
JB
9382
9383 return value_cast (type, arg2);
9384}
9385
284614f0
JB
9386/* Evaluating Ada expressions, and printing their result.
9387 ------------------------------------------------------
9388
21649b50
JB
9389 1. Introduction:
9390 ----------------
9391
284614f0
JB
9392 We usually evaluate an Ada expression in order to print its value.
9393 We also evaluate an expression in order to print its type, which
9394 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9395 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9396 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9397 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9398 similar.
9399
9400 Evaluating expressions is a little more complicated for Ada entities
9401 than it is for entities in languages such as C. The main reason for
9402 this is that Ada provides types whose definition might be dynamic.
9403 One example of such types is variant records. Or another example
9404 would be an array whose bounds can only be known at run time.
9405
9406 The following description is a general guide as to what should be
9407 done (and what should NOT be done) in order to evaluate an expression
9408 involving such types, and when. This does not cover how the semantic
9409 information is encoded by GNAT as this is covered separatly. For the
9410 document used as the reference for the GNAT encoding, see exp_dbug.ads
9411 in the GNAT sources.
9412
9413 Ideally, we should embed each part of this description next to its
9414 associated code. Unfortunately, the amount of code is so vast right
9415 now that it's hard to see whether the code handling a particular
9416 situation might be duplicated or not. One day, when the code is
9417 cleaned up, this guide might become redundant with the comments
9418 inserted in the code, and we might want to remove it.
9419
21649b50
JB
9420 2. ``Fixing'' an Entity, the Simple Case:
9421 -----------------------------------------
9422
284614f0
JB
9423 When evaluating Ada expressions, the tricky issue is that they may
9424 reference entities whose type contents and size are not statically
9425 known. Consider for instance a variant record:
9426
9427 type Rec (Empty : Boolean := True) is record
9428 case Empty is
9429 when True => null;
9430 when False => Value : Integer;
9431 end case;
9432 end record;
9433 Yes : Rec := (Empty => False, Value => 1);
9434 No : Rec := (empty => True);
9435
9436 The size and contents of that record depends on the value of the
9437 descriminant (Rec.Empty). At this point, neither the debugging
9438 information nor the associated type structure in GDB are able to
9439 express such dynamic types. So what the debugger does is to create
9440 "fixed" versions of the type that applies to the specific object.
9441 We also informally refer to this opperation as "fixing" an object,
9442 which means creating its associated fixed type.
9443
9444 Example: when printing the value of variable "Yes" above, its fixed
9445 type would look like this:
9446
9447 type Rec is record
9448 Empty : Boolean;
9449 Value : Integer;
9450 end record;
9451
9452 On the other hand, if we printed the value of "No", its fixed type
9453 would become:
9454
9455 type Rec is record
9456 Empty : Boolean;
9457 end record;
9458
9459 Things become a little more complicated when trying to fix an entity
9460 with a dynamic type that directly contains another dynamic type,
9461 such as an array of variant records, for instance. There are
9462 two possible cases: Arrays, and records.
9463
21649b50
JB
9464 3. ``Fixing'' Arrays:
9465 ---------------------
9466
9467 The type structure in GDB describes an array in terms of its bounds,
9468 and the type of its elements. By design, all elements in the array
9469 have the same type and we cannot represent an array of variant elements
9470 using the current type structure in GDB. When fixing an array,
9471 we cannot fix the array element, as we would potentially need one
9472 fixed type per element of the array. As a result, the best we can do
9473 when fixing an array is to produce an array whose bounds and size
9474 are correct (allowing us to read it from memory), but without having
9475 touched its element type. Fixing each element will be done later,
9476 when (if) necessary.
9477
9478 Arrays are a little simpler to handle than records, because the same
9479 amount of memory is allocated for each element of the array, even if
1b536f04 9480 the amount of space actually used by each element differs from element
21649b50 9481 to element. Consider for instance the following array of type Rec:
284614f0
JB
9482
9483 type Rec_Array is array (1 .. 2) of Rec;
9484
1b536f04
JB
9485 The actual amount of memory occupied by each element might be different
9486 from element to element, depending on the value of their discriminant.
21649b50 9487 But the amount of space reserved for each element in the array remains
1b536f04 9488 fixed regardless. So we simply need to compute that size using
21649b50
JB
9489 the debugging information available, from which we can then determine
9490 the array size (we multiply the number of elements of the array by
9491 the size of each element).
9492
9493 The simplest case is when we have an array of a constrained element
9494 type. For instance, consider the following type declarations:
9495
9496 type Bounded_String (Max_Size : Integer) is
9497 Length : Integer;
9498 Buffer : String (1 .. Max_Size);
9499 end record;
9500 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9501
9502 In this case, the compiler describes the array as an array of
9503 variable-size elements (identified by its XVS suffix) for which
9504 the size can be read in the parallel XVZ variable.
9505
9506 In the case of an array of an unconstrained element type, the compiler
9507 wraps the array element inside a private PAD type. This type should not
9508 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
9509 that we also use the adjective "aligner" in our code to designate
9510 these wrapper types.
9511
1b536f04 9512 In some cases, the size allocated for each element is statically
21649b50
JB
9513 known. In that case, the PAD type already has the correct size,
9514 and the array element should remain unfixed.
9515
9516 But there are cases when this size is not statically known.
9517 For instance, assuming that "Five" is an integer variable:
284614f0
JB
9518
9519 type Dynamic is array (1 .. Five) of Integer;
9520 type Wrapper (Has_Length : Boolean := False) is record
9521 Data : Dynamic;
9522 case Has_Length is
9523 when True => Length : Integer;
9524 when False => null;
9525 end case;
9526 end record;
9527 type Wrapper_Array is array (1 .. 2) of Wrapper;
9528
9529 Hello : Wrapper_Array := (others => (Has_Length => True,
9530 Data => (others => 17),
9531 Length => 1));
9532
9533
9534 The debugging info would describe variable Hello as being an
9535 array of a PAD type. The size of that PAD type is not statically
9536 known, but can be determined using a parallel XVZ variable.
9537 In that case, a copy of the PAD type with the correct size should
9538 be used for the fixed array.
9539
21649b50
JB
9540 3. ``Fixing'' record type objects:
9541 ----------------------------------
9542
9543 Things are slightly different from arrays in the case of dynamic
284614f0
JB
9544 record types. In this case, in order to compute the associated
9545 fixed type, we need to determine the size and offset of each of
9546 its components. This, in turn, requires us to compute the fixed
9547 type of each of these components.
9548
9549 Consider for instance the example:
9550
9551 type Bounded_String (Max_Size : Natural) is record
9552 Str : String (1 .. Max_Size);
9553 Length : Natural;
9554 end record;
9555 My_String : Bounded_String (Max_Size => 10);
9556
9557 In that case, the position of field "Length" depends on the size
9558 of field Str, which itself depends on the value of the Max_Size
21649b50 9559 discriminant. In order to fix the type of variable My_String,
284614f0
JB
9560 we need to fix the type of field Str. Therefore, fixing a variant
9561 record requires us to fix each of its components.
9562
9563 However, if a component does not have a dynamic size, the component
9564 should not be fixed. In particular, fields that use a PAD type
9565 should not fixed. Here is an example where this might happen
9566 (assuming type Rec above):
9567
9568 type Container (Big : Boolean) is record
9569 First : Rec;
9570 After : Integer;
9571 case Big is
9572 when True => Another : Integer;
9573 when False => null;
9574 end case;
9575 end record;
9576 My_Container : Container := (Big => False,
9577 First => (Empty => True),
9578 After => 42);
9579
9580 In that example, the compiler creates a PAD type for component First,
9581 whose size is constant, and then positions the component After just
9582 right after it. The offset of component After is therefore constant
9583 in this case.
9584
9585 The debugger computes the position of each field based on an algorithm
9586 that uses, among other things, the actual position and size of the field
21649b50
JB
9587 preceding it. Let's now imagine that the user is trying to print
9588 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
9589 end up computing the offset of field After based on the size of the
9590 fixed version of field First. And since in our example First has
9591 only one actual field, the size of the fixed type is actually smaller
9592 than the amount of space allocated to that field, and thus we would
9593 compute the wrong offset of field After.
9594
21649b50
JB
9595 To make things more complicated, we need to watch out for dynamic
9596 components of variant records (identified by the ___XVL suffix in
9597 the component name). Even if the target type is a PAD type, the size
9598 of that type might not be statically known. So the PAD type needs
9599 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9600 we might end up with the wrong size for our component. This can be
9601 observed with the following type declarations:
284614f0
JB
9602
9603 type Octal is new Integer range 0 .. 7;
9604 type Octal_Array is array (Positive range <>) of Octal;
9605 pragma Pack (Octal_Array);
9606
9607 type Octal_Buffer (Size : Positive) is record
9608 Buffer : Octal_Array (1 .. Size);
9609 Length : Integer;
9610 end record;
9611
9612 In that case, Buffer is a PAD type whose size is unset and needs
9613 to be computed by fixing the unwrapped type.
9614
21649b50
JB
9615 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9616 ----------------------------------------------------------
9617
9618 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
9619 thus far, be actually fixed?
9620
9621 The answer is: Only when referencing that element. For instance
9622 when selecting one component of a record, this specific component
9623 should be fixed at that point in time. Or when printing the value
9624 of a record, each component should be fixed before its value gets
9625 printed. Similarly for arrays, the element of the array should be
9626 fixed when printing each element of the array, or when extracting
9627 one element out of that array. On the other hand, fixing should
9628 not be performed on the elements when taking a slice of an array!
9629
9630 Note that one of the side-effects of miscomputing the offset and
9631 size of each field is that we end up also miscomputing the size
9632 of the containing type. This can have adverse results when computing
9633 the value of an entity. GDB fetches the value of an entity based
9634 on the size of its type, and thus a wrong size causes GDB to fetch
9635 the wrong amount of memory. In the case where the computed size is
9636 too small, GDB fetches too little data to print the value of our
9637 entiry. Results in this case as unpredicatble, as we usually read
9638 past the buffer containing the data =:-o. */
9639
9640/* Implement the evaluate_exp routine in the exp_descriptor structure
9641 for the Ada language. */
9642
52ce6436 9643static struct value *
ebf56fd3 9644ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 9645 int *pos, enum noside noside)
14f9c5c9
AS
9646{
9647 enum exp_opcode op;
b5385fc0 9648 int tem;
14f9c5c9
AS
9649 int pc;
9650 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
9651 struct type *type;
52ce6436 9652 int nargs, oplen;
d2e4a39e 9653 struct value **argvec;
14f9c5c9 9654
d2e4a39e
AS
9655 pc = *pos;
9656 *pos += 1;
14f9c5c9
AS
9657 op = exp->elts[pc].opcode;
9658
d2e4a39e 9659 switch (op)
14f9c5c9
AS
9660 {
9661 default:
9662 *pos -= 1;
6e48bd2c 9663 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
9664
9665 if (noside == EVAL_NORMAL)
9666 arg1 = unwrap_value (arg1);
6e48bd2c
JB
9667
9668 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
9669 then we need to perform the conversion manually, because
9670 evaluate_subexp_standard doesn't do it. This conversion is
9671 necessary in Ada because the different kinds of float/fixed
9672 types in Ada have different representations.
9673
9674 Similarly, we need to perform the conversion from OP_LONG
9675 ourselves. */
9676 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
9677 arg1 = ada_value_cast (expect_type, arg1, noside);
9678
9679 return arg1;
4c4b4cd2
PH
9680
9681 case OP_STRING:
9682 {
76a01679 9683 struct value *result;
5b4ee69b 9684
76a01679
JB
9685 *pos -= 1;
9686 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
9687 /* The result type will have code OP_STRING, bashed there from
9688 OP_ARRAY. Bash it back. */
df407dfe
AC
9689 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
9690 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 9691 return result;
4c4b4cd2 9692 }
14f9c5c9
AS
9693
9694 case UNOP_CAST:
9695 (*pos) += 2;
9696 type = exp->elts[pc + 1].type;
9697 arg1 = evaluate_subexp (type, exp, pos, noside);
9698 if (noside == EVAL_SKIP)
4c4b4cd2 9699 goto nosideret;
6e48bd2c 9700 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
9701 return arg1;
9702
4c4b4cd2
PH
9703 case UNOP_QUAL:
9704 (*pos) += 2;
9705 type = exp->elts[pc + 1].type;
9706 return ada_evaluate_subexp (type, exp, pos, noside);
9707
14f9c5c9
AS
9708 case BINOP_ASSIGN:
9709 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
9710 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9711 {
9712 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
9713 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
9714 return arg1;
9715 return ada_value_assign (arg1, arg1);
9716 }
003f3813
JB
9717 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9718 except if the lhs of our assignment is a convenience variable.
9719 In the case of assigning to a convenience variable, the lhs
9720 should be exactly the result of the evaluation of the rhs. */
9721 type = value_type (arg1);
9722 if (VALUE_LVAL (arg1) == lval_internalvar)
9723 type = NULL;
9724 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 9725 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 9726 return arg1;
df407dfe
AC
9727 if (ada_is_fixed_point_type (value_type (arg1)))
9728 arg2 = cast_to_fixed (value_type (arg1), arg2);
9729 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 9730 error
323e0a4a 9731 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 9732 else
df407dfe 9733 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 9734 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
9735
9736 case BINOP_ADD:
9737 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9738 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9739 if (noside == EVAL_SKIP)
4c4b4cd2 9740 goto nosideret;
2ac8a782
JB
9741 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9742 return (value_from_longest
9743 (value_type (arg1),
9744 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
9745 if ((ada_is_fixed_point_type (value_type (arg1))
9746 || ada_is_fixed_point_type (value_type (arg2)))
9747 && value_type (arg1) != value_type (arg2))
323e0a4a 9748 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
9749 /* Do the addition, and cast the result to the type of the first
9750 argument. We cannot cast the result to a reference type, so if
9751 ARG1 is a reference type, find its underlying type. */
9752 type = value_type (arg1);
9753 while (TYPE_CODE (type) == TYPE_CODE_REF)
9754 type = TYPE_TARGET_TYPE (type);
f44316fa 9755 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 9756 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
9757
9758 case BINOP_SUB:
9759 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9760 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9761 if (noside == EVAL_SKIP)
4c4b4cd2 9762 goto nosideret;
2ac8a782
JB
9763 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9764 return (value_from_longest
9765 (value_type (arg1),
9766 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
9767 if ((ada_is_fixed_point_type (value_type (arg1))
9768 || ada_is_fixed_point_type (value_type (arg2)))
9769 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
9770 error (_("Operands of fixed-point subtraction "
9771 "must have the same type"));
b7789565
JB
9772 /* Do the substraction, and cast the result to the type of the first
9773 argument. We cannot cast the result to a reference type, so if
9774 ARG1 is a reference type, find its underlying type. */
9775 type = value_type (arg1);
9776 while (TYPE_CODE (type) == TYPE_CODE_REF)
9777 type = TYPE_TARGET_TYPE (type);
f44316fa 9778 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 9779 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
9780
9781 case BINOP_MUL:
9782 case BINOP_DIV:
e1578042
JB
9783 case BINOP_REM:
9784 case BINOP_MOD:
14f9c5c9
AS
9785 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9786 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9787 if (noside == EVAL_SKIP)
4c4b4cd2 9788 goto nosideret;
e1578042 9789 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
9790 {
9791 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9792 return value_zero (value_type (arg1), not_lval);
9793 }
14f9c5c9 9794 else
4c4b4cd2 9795 {
a53b7a21 9796 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 9797 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 9798 arg1 = cast_from_fixed (type, arg1);
df407dfe 9799 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9800 arg2 = cast_from_fixed (type, arg2);
f44316fa 9801 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
9802 return ada_value_binop (arg1, arg2, op);
9803 }
9804
4c4b4cd2
PH
9805 case BINOP_EQUAL:
9806 case BINOP_NOTEQUAL:
14f9c5c9 9807 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 9808 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 9809 if (noside == EVAL_SKIP)
76a01679 9810 goto nosideret;
4c4b4cd2 9811 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9812 tem = 0;
4c4b4cd2 9813 else
f44316fa
UW
9814 {
9815 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9816 tem = ada_value_equal (arg1, arg2);
9817 }
4c4b4cd2 9818 if (op == BINOP_NOTEQUAL)
76a01679 9819 tem = !tem;
fbb06eb1
UW
9820 type = language_bool_type (exp->language_defn, exp->gdbarch);
9821 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
9822
9823 case UNOP_NEG:
9824 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9825 if (noside == EVAL_SKIP)
9826 goto nosideret;
df407dfe
AC
9827 else if (ada_is_fixed_point_type (value_type (arg1)))
9828 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 9829 else
f44316fa
UW
9830 {
9831 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9832 return value_neg (arg1);
9833 }
4c4b4cd2 9834
2330c6c6
JB
9835 case BINOP_LOGICAL_AND:
9836 case BINOP_LOGICAL_OR:
9837 case UNOP_LOGICAL_NOT:
000d5124
JB
9838 {
9839 struct value *val;
9840
9841 *pos -= 1;
9842 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
9843 type = language_bool_type (exp->language_defn, exp->gdbarch);
9844 return value_cast (type, val);
000d5124 9845 }
2330c6c6
JB
9846
9847 case BINOP_BITWISE_AND:
9848 case BINOP_BITWISE_IOR:
9849 case BINOP_BITWISE_XOR:
000d5124
JB
9850 {
9851 struct value *val;
9852
9853 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
9854 *pos = pc;
9855 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
9856
9857 return value_cast (value_type (arg1), val);
9858 }
2330c6c6 9859
14f9c5c9
AS
9860 case OP_VAR_VALUE:
9861 *pos -= 1;
6799def4 9862
14f9c5c9 9863 if (noside == EVAL_SKIP)
4c4b4cd2
PH
9864 {
9865 *pos += 4;
9866 goto nosideret;
9867 }
9868 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
9869 /* Only encountered when an unresolved symbol occurs in a
9870 context other than a function call, in which case, it is
52ce6436 9871 invalid. */
323e0a4a 9872 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 9873 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
14f9c5c9 9874 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 9875 {
0c1f74cf 9876 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
9877 /* Check to see if this is a tagged type. We also need to handle
9878 the case where the type is a reference to a tagged type, but
9879 we have to be careful to exclude pointers to tagged types.
9880 The latter should be shown as usual (as a pointer), whereas
9881 a reference should mostly be transparent to the user. */
9882 if (ada_is_tagged_type (type, 0)
9883 || (TYPE_CODE(type) == TYPE_CODE_REF
9884 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0c1f74cf
JB
9885 {
9886 /* Tagged types are a little special in the fact that the real
9887 type is dynamic and can only be determined by inspecting the
9888 object's tag. This means that we need to get the object's
9889 value first (EVAL_NORMAL) and then extract the actual object
9890 type from its tag.
9891
9892 Note that we cannot skip the final step where we extract
9893 the object type from its tag, because the EVAL_NORMAL phase
9894 results in dynamic components being resolved into fixed ones.
9895 This can cause problems when trying to print the type
9896 description of tagged types whose parent has a dynamic size:
9897 We use the type name of the "_parent" component in order
9898 to print the name of the ancestor type in the type description.
9899 If that component had a dynamic size, the resolution into
9900 a fixed type would result in the loss of that type name,
9901 thus preventing us from printing the name of the ancestor
9902 type in the type description. */
9903 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
b50d69b5
JG
9904
9905 if (TYPE_CODE (type) != TYPE_CODE_REF)
9906 {
9907 struct type *actual_type;
9908
9909 actual_type = type_from_tag (ada_value_tag (arg1));
9910 if (actual_type == NULL)
9911 /* If, for some reason, we were unable to determine
9912 the actual type from the tag, then use the static
9913 approximation that we just computed as a fallback.
9914 This can happen if the debugging information is
9915 incomplete, for instance. */
9916 actual_type = type;
9917 return value_zero (actual_type, not_lval);
9918 }
9919 else
9920 {
9921 /* In the case of a ref, ada_coerce_ref takes care
9922 of determining the actual type. But the evaluation
9923 should return a ref as it should be valid to ask
9924 for its address; so rebuild a ref after coerce. */
9925 arg1 = ada_coerce_ref (arg1);
9926 return value_ref (arg1);
9927 }
0c1f74cf
JB
9928 }
9929
4c4b4cd2
PH
9930 *pos += 4;
9931 return value_zero
9932 (to_static_fixed_type
9933 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
9934 not_lval);
9935 }
d2e4a39e 9936 else
4c4b4cd2 9937 {
284614f0 9938 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
4c4b4cd2
PH
9939 return ada_to_fixed_value (arg1);
9940 }
9941
9942 case OP_FUNCALL:
9943 (*pos) += 2;
9944
9945 /* Allocate arg vector, including space for the function to be
9946 called in argvec[0] and a terminating NULL. */
9947 nargs = longest_to_int (exp->elts[pc + 1].longconst);
9948 argvec =
9949 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
9950
9951 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 9952 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 9953 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
9954 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
9955 else
9956 {
9957 for (tem = 0; tem <= nargs; tem += 1)
9958 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9959 argvec[tem] = 0;
9960
9961 if (noside == EVAL_SKIP)
9962 goto nosideret;
9963 }
9964
ad82864c
JB
9965 if (ada_is_constrained_packed_array_type
9966 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 9967 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
9968 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
9969 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
9970 /* This is a packed array that has already been fixed, and
9971 therefore already coerced to a simple array. Nothing further
9972 to do. */
9973 ;
df407dfe
AC
9974 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
9975 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
76a01679 9976 && VALUE_LVAL (argvec[0]) == lval_memory))
4c4b4cd2
PH
9977 argvec[0] = value_addr (argvec[0]);
9978
df407dfe 9979 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
9980
9981 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
9982 them. So, if this is an array typedef (encoding use for array
9983 access types encoded as fat pointers), strip it now. */
720d1a40
JB
9984 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
9985 type = ada_typedef_target_type (type);
9986
4c4b4cd2
PH
9987 if (TYPE_CODE (type) == TYPE_CODE_PTR)
9988 {
61ee279c 9989 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
9990 {
9991 case TYPE_CODE_FUNC:
61ee279c 9992 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
9993 break;
9994 case TYPE_CODE_ARRAY:
9995 break;
9996 case TYPE_CODE_STRUCT:
9997 if (noside != EVAL_AVOID_SIDE_EFFECTS)
9998 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 9999 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10000 break;
10001 default:
323e0a4a 10002 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10003 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10004 break;
10005 }
10006 }
10007
10008 switch (TYPE_CODE (type))
10009 {
10010 case TYPE_CODE_FUNC:
10011 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972
PH
10012 {
10013 struct type *rtype = TYPE_TARGET_TYPE (type);
10014
10015 if (TYPE_GNU_IFUNC (type))
10016 return allocate_value (TYPE_TARGET_TYPE (rtype));
10017 return allocate_value (rtype);
10018 }
4c4b4cd2 10019 return call_function_by_hand (argvec[0], nargs, argvec + 1);
c8ea1972
PH
10020 case TYPE_CODE_INTERNAL_FUNCTION:
10021 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10022 /* We don't know anything about what the internal
10023 function might return, but we have to return
10024 something. */
10025 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10026 not_lval);
10027 else
10028 return call_internal_function (exp->gdbarch, exp->language_defn,
10029 argvec[0], nargs, argvec + 1);
10030
4c4b4cd2
PH
10031 case TYPE_CODE_STRUCT:
10032 {
10033 int arity;
10034
4c4b4cd2
PH
10035 arity = ada_array_arity (type);
10036 type = ada_array_element_type (type, nargs);
10037 if (type == NULL)
323e0a4a 10038 error (_("cannot subscript or call a record"));
4c4b4cd2 10039 if (arity != nargs)
323e0a4a 10040 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10041 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10042 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10043 return
10044 unwrap_value (ada_value_subscript
10045 (argvec[0], nargs, argvec + 1));
10046 }
10047 case TYPE_CODE_ARRAY:
10048 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10049 {
10050 type = ada_array_element_type (type, nargs);
10051 if (type == NULL)
323e0a4a 10052 error (_("element type of array unknown"));
4c4b4cd2 10053 else
0a07e705 10054 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10055 }
10056 return
10057 unwrap_value (ada_value_subscript
10058 (ada_coerce_to_simple_array (argvec[0]),
10059 nargs, argvec + 1));
10060 case TYPE_CODE_PTR: /* Pointer to array */
10061 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10062 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10063 {
10064 type = ada_array_element_type (type, nargs);
10065 if (type == NULL)
323e0a4a 10066 error (_("element type of array unknown"));
4c4b4cd2 10067 else
0a07e705 10068 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10069 }
10070 return
10071 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
10072 nargs, argvec + 1));
10073
10074 default:
e1d5a0d2
PH
10075 error (_("Attempt to index or call something other than an "
10076 "array or function"));
4c4b4cd2
PH
10077 }
10078
10079 case TERNOP_SLICE:
10080 {
10081 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10082 struct value *low_bound_val =
10083 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
10084 struct value *high_bound_val =
10085 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10086 LONGEST low_bound;
10087 LONGEST high_bound;
5b4ee69b 10088
994b9211
AC
10089 low_bound_val = coerce_ref (low_bound_val);
10090 high_bound_val = coerce_ref (high_bound_val);
714e53ab
PH
10091 low_bound = pos_atr (low_bound_val);
10092 high_bound = pos_atr (high_bound_val);
963a6417 10093
4c4b4cd2
PH
10094 if (noside == EVAL_SKIP)
10095 goto nosideret;
10096
4c4b4cd2
PH
10097 /* If this is a reference to an aligner type, then remove all
10098 the aligners. */
df407dfe
AC
10099 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10100 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10101 TYPE_TARGET_TYPE (value_type (array)) =
10102 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 10103
ad82864c 10104 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 10105 error (_("cannot slice a packed array"));
4c4b4cd2
PH
10106
10107 /* If this is a reference to an array or an array lvalue,
10108 convert to a pointer. */
df407dfe
AC
10109 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10110 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
10111 && VALUE_LVAL (array) == lval_memory))
10112 array = value_addr (array);
10113
1265e4aa 10114 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 10115 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 10116 (value_type (array))))
0b5d8877 10117 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
10118
10119 array = ada_coerce_to_simple_array_ptr (array);
10120
714e53ab
PH
10121 /* If we have more than one level of pointer indirection,
10122 dereference the value until we get only one level. */
df407dfe
AC
10123 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10124 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
10125 == TYPE_CODE_PTR))
10126 array = value_ind (array);
10127
10128 /* Make sure we really do have an array type before going further,
10129 to avoid a SEGV when trying to get the index type or the target
10130 type later down the road if the debug info generated by
10131 the compiler is incorrect or incomplete. */
df407dfe 10132 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 10133 error (_("cannot take slice of non-array"));
714e53ab 10134
828292f2
JB
10135 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10136 == TYPE_CODE_PTR)
4c4b4cd2 10137 {
828292f2
JB
10138 struct type *type0 = ada_check_typedef (value_type (array));
10139
0b5d8877 10140 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 10141 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
10142 else
10143 {
10144 struct type *arr_type0 =
828292f2 10145 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 10146
f5938064
JG
10147 return ada_value_slice_from_ptr (array, arr_type0,
10148 longest_to_int (low_bound),
10149 longest_to_int (high_bound));
4c4b4cd2
PH
10150 }
10151 }
10152 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10153 return array;
10154 else if (high_bound < low_bound)
df407dfe 10155 return empty_array (value_type (array), low_bound);
4c4b4cd2 10156 else
529cad9c
PH
10157 return ada_value_slice (array, longest_to_int (low_bound),
10158 longest_to_int (high_bound));
4c4b4cd2 10159 }
14f9c5c9 10160
4c4b4cd2
PH
10161 case UNOP_IN_RANGE:
10162 (*pos) += 2;
10163 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 10164 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 10165
14f9c5c9 10166 if (noside == EVAL_SKIP)
4c4b4cd2 10167 goto nosideret;
14f9c5c9 10168
4c4b4cd2
PH
10169 switch (TYPE_CODE (type))
10170 {
10171 default:
e1d5a0d2
PH
10172 lim_warning (_("Membership test incompletely implemented; "
10173 "always returns true"));
fbb06eb1
UW
10174 type = language_bool_type (exp->language_defn, exp->gdbarch);
10175 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
10176
10177 case TYPE_CODE_RANGE:
030b4912
UW
10178 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10179 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
10180 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10181 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
10182 type = language_bool_type (exp->language_defn, exp->gdbarch);
10183 return
10184 value_from_longest (type,
4c4b4cd2
PH
10185 (value_less (arg1, arg3)
10186 || value_equal (arg1, arg3))
10187 && (value_less (arg2, arg1)
10188 || value_equal (arg2, arg1)));
10189 }
10190
10191 case BINOP_IN_BOUNDS:
14f9c5c9 10192 (*pos) += 2;
4c4b4cd2
PH
10193 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10194 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10195
4c4b4cd2
PH
10196 if (noside == EVAL_SKIP)
10197 goto nosideret;
14f9c5c9 10198
4c4b4cd2 10199 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
10200 {
10201 type = language_bool_type (exp->language_defn, exp->gdbarch);
10202 return value_zero (type, not_lval);
10203 }
14f9c5c9 10204
4c4b4cd2 10205 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 10206
1eea4ebd
UW
10207 type = ada_index_type (value_type (arg2), tem, "range");
10208 if (!type)
10209 type = value_type (arg1);
14f9c5c9 10210
1eea4ebd
UW
10211 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10212 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 10213
f44316fa
UW
10214 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10215 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10216 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10217 return
fbb06eb1 10218 value_from_longest (type,
4c4b4cd2
PH
10219 (value_less (arg1, arg3)
10220 || value_equal (arg1, arg3))
10221 && (value_less (arg2, arg1)
10222 || value_equal (arg2, arg1)));
10223
10224 case TERNOP_IN_RANGE:
10225 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10226 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10227 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10228
10229 if (noside == EVAL_SKIP)
10230 goto nosideret;
10231
f44316fa
UW
10232 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10233 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10234 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10235 return
fbb06eb1 10236 value_from_longest (type,
4c4b4cd2
PH
10237 (value_less (arg1, arg3)
10238 || value_equal (arg1, arg3))
10239 && (value_less (arg2, arg1)
10240 || value_equal (arg2, arg1)));
10241
10242 case OP_ATR_FIRST:
10243 case OP_ATR_LAST:
10244 case OP_ATR_LENGTH:
10245 {
76a01679 10246 struct type *type_arg;
5b4ee69b 10247
76a01679
JB
10248 if (exp->elts[*pos].opcode == OP_TYPE)
10249 {
10250 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10251 arg1 = NULL;
5bc23cb3 10252 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
10253 }
10254 else
10255 {
10256 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10257 type_arg = NULL;
10258 }
10259
10260 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 10261 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
10262 tem = longest_to_int (exp->elts[*pos + 2].longconst);
10263 *pos += 4;
10264
10265 if (noside == EVAL_SKIP)
10266 goto nosideret;
10267
10268 if (type_arg == NULL)
10269 {
10270 arg1 = ada_coerce_ref (arg1);
10271
ad82864c 10272 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
10273 arg1 = ada_coerce_to_simple_array (arg1);
10274
1eea4ebd
UW
10275 type = ada_index_type (value_type (arg1), tem,
10276 ada_attribute_name (op));
10277 if (type == NULL)
10278 type = builtin_type (exp->gdbarch)->builtin_int;
76a01679
JB
10279
10280 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 10281 return allocate_value (type);
76a01679
JB
10282
10283 switch (op)
10284 {
10285 default: /* Should never happen. */
323e0a4a 10286 error (_("unexpected attribute encountered"));
76a01679 10287 case OP_ATR_FIRST:
1eea4ebd
UW
10288 return value_from_longest
10289 (type, ada_array_bound (arg1, tem, 0));
76a01679 10290 case OP_ATR_LAST:
1eea4ebd
UW
10291 return value_from_longest
10292 (type, ada_array_bound (arg1, tem, 1));
76a01679 10293 case OP_ATR_LENGTH:
1eea4ebd
UW
10294 return value_from_longest
10295 (type, ada_array_length (arg1, tem));
76a01679
JB
10296 }
10297 }
10298 else if (discrete_type_p (type_arg))
10299 {
10300 struct type *range_type;
0d5cff50 10301 const char *name = ada_type_name (type_arg);
5b4ee69b 10302
76a01679
JB
10303 range_type = NULL;
10304 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 10305 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
10306 if (range_type == NULL)
10307 range_type = type_arg;
10308 switch (op)
10309 {
10310 default:
323e0a4a 10311 error (_("unexpected attribute encountered"));
76a01679 10312 case OP_ATR_FIRST:
690cc4eb 10313 return value_from_longest
43bbcdc2 10314 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 10315 case OP_ATR_LAST:
690cc4eb 10316 return value_from_longest
43bbcdc2 10317 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 10318 case OP_ATR_LENGTH:
323e0a4a 10319 error (_("the 'length attribute applies only to array types"));
76a01679
JB
10320 }
10321 }
10322 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 10323 error (_("unimplemented type attribute"));
76a01679
JB
10324 else
10325 {
10326 LONGEST low, high;
10327
ad82864c
JB
10328 if (ada_is_constrained_packed_array_type (type_arg))
10329 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 10330
1eea4ebd 10331 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
76a01679 10332 if (type == NULL)
1eea4ebd
UW
10333 type = builtin_type (exp->gdbarch)->builtin_int;
10334
76a01679
JB
10335 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10336 return allocate_value (type);
10337
10338 switch (op)
10339 {
10340 default:
323e0a4a 10341 error (_("unexpected attribute encountered"));
76a01679 10342 case OP_ATR_FIRST:
1eea4ebd 10343 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
10344 return value_from_longest (type, low);
10345 case OP_ATR_LAST:
1eea4ebd 10346 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10347 return value_from_longest (type, high);
10348 case OP_ATR_LENGTH:
1eea4ebd
UW
10349 low = ada_array_bound_from_type (type_arg, tem, 0);
10350 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10351 return value_from_longest (type, high - low + 1);
10352 }
10353 }
14f9c5c9
AS
10354 }
10355
4c4b4cd2
PH
10356 case OP_ATR_TAG:
10357 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10358 if (noside == EVAL_SKIP)
76a01679 10359 goto nosideret;
4c4b4cd2
PH
10360
10361 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10362 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
10363
10364 return ada_value_tag (arg1);
10365
10366 case OP_ATR_MIN:
10367 case OP_ATR_MAX:
10368 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10369 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10370 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10371 if (noside == EVAL_SKIP)
76a01679 10372 goto nosideret;
d2e4a39e 10373 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10374 return value_zero (value_type (arg1), not_lval);
14f9c5c9 10375 else
f44316fa
UW
10376 {
10377 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10378 return value_binop (arg1, arg2,
10379 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
10380 }
14f9c5c9 10381
4c4b4cd2
PH
10382 case OP_ATR_MODULUS:
10383 {
31dedfee 10384 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 10385
5b4ee69b 10386 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
10387 if (noside == EVAL_SKIP)
10388 goto nosideret;
4c4b4cd2 10389
76a01679 10390 if (!ada_is_modular_type (type_arg))
323e0a4a 10391 error (_("'modulus must be applied to modular type"));
4c4b4cd2 10392
76a01679
JB
10393 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
10394 ada_modulus (type_arg));
4c4b4cd2
PH
10395 }
10396
10397
10398 case OP_ATR_POS:
10399 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10400 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10401 if (noside == EVAL_SKIP)
76a01679 10402 goto nosideret;
3cb382c9
UW
10403 type = builtin_type (exp->gdbarch)->builtin_int;
10404 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10405 return value_zero (type, not_lval);
14f9c5c9 10406 else
3cb382c9 10407 return value_pos_atr (type, arg1);
14f9c5c9 10408
4c4b4cd2
PH
10409 case OP_ATR_SIZE:
10410 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
10411 type = value_type (arg1);
10412
10413 /* If the argument is a reference, then dereference its type, since
10414 the user is really asking for the size of the actual object,
10415 not the size of the pointer. */
10416 if (TYPE_CODE (type) == TYPE_CODE_REF)
10417 type = TYPE_TARGET_TYPE (type);
10418
4c4b4cd2 10419 if (noside == EVAL_SKIP)
76a01679 10420 goto nosideret;
4c4b4cd2 10421 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 10422 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 10423 else
22601c15 10424 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 10425 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
10426
10427 case OP_ATR_VAL:
10428 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 10429 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 10430 type = exp->elts[pc + 2].type;
14f9c5c9 10431 if (noside == EVAL_SKIP)
76a01679 10432 goto nosideret;
4c4b4cd2 10433 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10434 return value_zero (type, not_lval);
4c4b4cd2 10435 else
76a01679 10436 return value_val_atr (type, arg1);
4c4b4cd2
PH
10437
10438 case BINOP_EXP:
10439 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10440 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10441 if (noside == EVAL_SKIP)
10442 goto nosideret;
10443 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10444 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 10445 else
f44316fa
UW
10446 {
10447 /* For integer exponentiation operations,
10448 only promote the first argument. */
10449 if (is_integral_type (value_type (arg2)))
10450 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10451 else
10452 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10453
10454 return value_binop (arg1, arg2, op);
10455 }
4c4b4cd2
PH
10456
10457 case UNOP_PLUS:
10458 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10459 if (noside == EVAL_SKIP)
10460 goto nosideret;
10461 else
10462 return arg1;
10463
10464 case UNOP_ABS:
10465 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10466 if (noside == EVAL_SKIP)
10467 goto nosideret;
f44316fa 10468 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 10469 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 10470 return value_neg (arg1);
14f9c5c9 10471 else
4c4b4cd2 10472 return arg1;
14f9c5c9
AS
10473
10474 case UNOP_IND:
6b0d7253 10475 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10476 if (noside == EVAL_SKIP)
4c4b4cd2 10477 goto nosideret;
df407dfe 10478 type = ada_check_typedef (value_type (arg1));
14f9c5c9 10479 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
10480 {
10481 if (ada_is_array_descriptor_type (type))
10482 /* GDB allows dereferencing GNAT array descriptors. */
10483 {
10484 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 10485
4c4b4cd2 10486 if (arrType == NULL)
323e0a4a 10487 error (_("Attempt to dereference null array pointer."));
00a4c844 10488 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
10489 }
10490 else if (TYPE_CODE (type) == TYPE_CODE_PTR
10491 || TYPE_CODE (type) == TYPE_CODE_REF
10492 /* In C you can dereference an array to get the 1st elt. */
10493 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab
PH
10494 {
10495 type = to_static_fixed_type
10496 (ada_aligned_type
10497 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10498 check_size (type);
10499 return value_zero (type, lval_memory);
10500 }
4c4b4cd2 10501 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
10502 {
10503 /* GDB allows dereferencing an int. */
10504 if (expect_type == NULL)
10505 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10506 lval_memory);
10507 else
10508 {
10509 expect_type =
10510 to_static_fixed_type (ada_aligned_type (expect_type));
10511 return value_zero (expect_type, lval_memory);
10512 }
10513 }
4c4b4cd2 10514 else
323e0a4a 10515 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 10516 }
0963b4bd 10517 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 10518 type = ada_check_typedef (value_type (arg1));
d2e4a39e 10519
96967637
JB
10520 if (TYPE_CODE (type) == TYPE_CODE_INT)
10521 /* GDB allows dereferencing an int. If we were given
10522 the expect_type, then use that as the target type.
10523 Otherwise, assume that the target type is an int. */
10524 {
10525 if (expect_type != NULL)
10526 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10527 arg1));
10528 else
10529 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10530 (CORE_ADDR) value_as_address (arg1));
10531 }
6b0d7253 10532
4c4b4cd2
PH
10533 if (ada_is_array_descriptor_type (type))
10534 /* GDB allows dereferencing GNAT array descriptors. */
10535 return ada_coerce_to_simple_array (arg1);
14f9c5c9 10536 else
4c4b4cd2 10537 return ada_value_ind (arg1);
14f9c5c9
AS
10538
10539 case STRUCTOP_STRUCT:
10540 tem = longest_to_int (exp->elts[pc + 1].longconst);
10541 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
10542 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10543 if (noside == EVAL_SKIP)
4c4b4cd2 10544 goto nosideret;
14f9c5c9 10545 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10546 {
df407dfe 10547 struct type *type1 = value_type (arg1);
5b4ee69b 10548
76a01679
JB
10549 if (ada_is_tagged_type (type1, 1))
10550 {
10551 type = ada_lookup_struct_elt_type (type1,
10552 &exp->elts[pc + 2].string,
10553 1, 1, NULL);
10554 if (type == NULL)
10555 /* In this case, we assume that the field COULD exist
10556 in some extension of the type. Return an object of
10557 "type" void, which will match any formal
0963b4bd 10558 (see ada_type_match). */
30b15541
UW
10559 return value_zero (builtin_type (exp->gdbarch)->builtin_void,
10560 lval_memory);
76a01679
JB
10561 }
10562 else
10563 type =
10564 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
10565 0, NULL);
10566
10567 return value_zero (ada_aligned_type (type), lval_memory);
10568 }
14f9c5c9 10569 else
284614f0
JB
10570 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
10571 arg1 = unwrap_value (arg1);
10572 return ada_to_fixed_value (arg1);
10573
14f9c5c9 10574 case OP_TYPE:
4c4b4cd2
PH
10575 /* The value is not supposed to be used. This is here to make it
10576 easier to accommodate expressions that contain types. */
14f9c5c9
AS
10577 (*pos) += 2;
10578 if (noside == EVAL_SKIP)
4c4b4cd2 10579 goto nosideret;
14f9c5c9 10580 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 10581 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 10582 else
323e0a4a 10583 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
10584
10585 case OP_AGGREGATE:
10586 case OP_CHOICES:
10587 case OP_OTHERS:
10588 case OP_DISCRETE_RANGE:
10589 case OP_POSITIONAL:
10590 case OP_NAME:
10591 if (noside == EVAL_NORMAL)
10592 switch (op)
10593 {
10594 case OP_NAME:
10595 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 10596 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
10597 case OP_AGGREGATE:
10598 error (_("Aggregates only allowed on the right of an assignment"));
10599 default:
0963b4bd
MS
10600 internal_error (__FILE__, __LINE__,
10601 _("aggregate apparently mangled"));
52ce6436
PH
10602 }
10603
10604 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10605 *pos += oplen - 1;
10606 for (tem = 0; tem < nargs; tem += 1)
10607 ada_evaluate_subexp (NULL, exp, pos, noside);
10608 goto nosideret;
14f9c5c9
AS
10609 }
10610
10611nosideret:
22601c15 10612 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
14f9c5c9 10613}
14f9c5c9 10614\f
d2e4a39e 10615
4c4b4cd2 10616 /* Fixed point */
14f9c5c9
AS
10617
10618/* If TYPE encodes an Ada fixed-point type, return the suffix of the
10619 type name that encodes the 'small and 'delta information.
4c4b4cd2 10620 Otherwise, return NULL. */
14f9c5c9 10621
d2e4a39e 10622static const char *
ebf56fd3 10623fixed_type_info (struct type *type)
14f9c5c9 10624{
d2e4a39e 10625 const char *name = ada_type_name (type);
14f9c5c9
AS
10626 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
10627
d2e4a39e
AS
10628 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
10629 {
14f9c5c9 10630 const char *tail = strstr (name, "___XF_");
5b4ee69b 10631
14f9c5c9 10632 if (tail == NULL)
4c4b4cd2 10633 return NULL;
d2e4a39e 10634 else
4c4b4cd2 10635 return tail + 5;
14f9c5c9
AS
10636 }
10637 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
10638 return fixed_type_info (TYPE_TARGET_TYPE (type));
10639 else
10640 return NULL;
10641}
10642
4c4b4cd2 10643/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
10644
10645int
ebf56fd3 10646ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
10647{
10648 return fixed_type_info (type) != NULL;
10649}
10650
4c4b4cd2
PH
10651/* Return non-zero iff TYPE represents a System.Address type. */
10652
10653int
10654ada_is_system_address_type (struct type *type)
10655{
10656 return (TYPE_NAME (type)
10657 && strcmp (TYPE_NAME (type), "system__address") == 0);
10658}
10659
14f9c5c9
AS
10660/* Assuming that TYPE is the representation of an Ada fixed-point
10661 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 10662 delta cannot be determined. */
14f9c5c9
AS
10663
10664DOUBLEST
ebf56fd3 10665ada_delta (struct type *type)
14f9c5c9
AS
10666{
10667 const char *encoding = fixed_type_info (type);
facc390f 10668 DOUBLEST num, den;
14f9c5c9 10669
facc390f
JB
10670 /* Strictly speaking, num and den are encoded as integer. However,
10671 they may not fit into a long, and they will have to be converted
10672 to DOUBLEST anyway. So scan them as DOUBLEST. */
10673 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10674 &num, &den) < 2)
14f9c5c9 10675 return -1.0;
d2e4a39e 10676 else
facc390f 10677 return num / den;
14f9c5c9
AS
10678}
10679
10680/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 10681 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
10682
10683static DOUBLEST
ebf56fd3 10684scaling_factor (struct type *type)
14f9c5c9
AS
10685{
10686 const char *encoding = fixed_type_info (type);
facc390f 10687 DOUBLEST num0, den0, num1, den1;
14f9c5c9 10688 int n;
d2e4a39e 10689
facc390f
JB
10690 /* Strictly speaking, num's and den's are encoded as integer. However,
10691 they may not fit into a long, and they will have to be converted
10692 to DOUBLEST anyway. So scan them as DOUBLEST. */
10693 n = sscanf (encoding,
10694 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
10695 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10696 &num0, &den0, &num1, &den1);
14f9c5c9
AS
10697
10698 if (n < 2)
10699 return 1.0;
10700 else if (n == 4)
facc390f 10701 return num1 / den1;
d2e4a39e 10702 else
facc390f 10703 return num0 / den0;
14f9c5c9
AS
10704}
10705
10706
10707/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 10708 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
10709
10710DOUBLEST
ebf56fd3 10711ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 10712{
d2e4a39e 10713 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
10714}
10715
4c4b4cd2
PH
10716/* The representation of a fixed-point value of type TYPE
10717 corresponding to the value X. */
14f9c5c9
AS
10718
10719LONGEST
ebf56fd3 10720ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
10721{
10722 return (LONGEST) (x / scaling_factor (type) + 0.5);
10723}
10724
14f9c5c9 10725\f
d2e4a39e 10726
4c4b4cd2 10727 /* Range types */
14f9c5c9
AS
10728
10729/* Scan STR beginning at position K for a discriminant name, and
10730 return the value of that discriminant field of DVAL in *PX. If
10731 PNEW_K is not null, put the position of the character beyond the
10732 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 10733 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
10734
10735static int
07d8f827 10736scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
76a01679 10737 int *pnew_k)
14f9c5c9
AS
10738{
10739 static char *bound_buffer = NULL;
10740 static size_t bound_buffer_len = 0;
10741 char *bound;
10742 char *pend;
d2e4a39e 10743 struct value *bound_val;
14f9c5c9
AS
10744
10745 if (dval == NULL || str == NULL || str[k] == '\0')
10746 return 0;
10747
d2e4a39e 10748 pend = strstr (str + k, "__");
14f9c5c9
AS
10749 if (pend == NULL)
10750 {
d2e4a39e 10751 bound = str + k;
14f9c5c9
AS
10752 k += strlen (bound);
10753 }
d2e4a39e 10754 else
14f9c5c9 10755 {
d2e4a39e 10756 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
14f9c5c9 10757 bound = bound_buffer;
d2e4a39e
AS
10758 strncpy (bound_buffer, str + k, pend - (str + k));
10759 bound[pend - (str + k)] = '\0';
10760 k = pend - str;
14f9c5c9 10761 }
d2e4a39e 10762
df407dfe 10763 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
10764 if (bound_val == NULL)
10765 return 0;
10766
10767 *px = value_as_long (bound_val);
10768 if (pnew_k != NULL)
10769 *pnew_k = k;
10770 return 1;
10771}
10772
10773/* Value of variable named NAME in the current environment. If
10774 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
10775 otherwise causes an error with message ERR_MSG. */
10776
d2e4a39e
AS
10777static struct value *
10778get_var_value (char *name, char *err_msg)
14f9c5c9 10779{
4c4b4cd2 10780 struct ada_symbol_info *syms;
14f9c5c9
AS
10781 int nsyms;
10782
4c4b4cd2 10783 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
4eeaa230 10784 &syms);
14f9c5c9
AS
10785
10786 if (nsyms != 1)
10787 {
10788 if (err_msg == NULL)
4c4b4cd2 10789 return 0;
14f9c5c9 10790 else
8a3fe4f8 10791 error (("%s"), err_msg);
14f9c5c9
AS
10792 }
10793
4c4b4cd2 10794 return value_of_variable (syms[0].sym, syms[0].block);
14f9c5c9 10795}
d2e4a39e 10796
14f9c5c9 10797/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
10798 no such variable found, returns 0, and sets *FLAG to 0. If
10799 successful, sets *FLAG to 1. */
10800
14f9c5c9 10801LONGEST
4c4b4cd2 10802get_int_var_value (char *name, int *flag)
14f9c5c9 10803{
4c4b4cd2 10804 struct value *var_val = get_var_value (name, 0);
d2e4a39e 10805
14f9c5c9
AS
10806 if (var_val == 0)
10807 {
10808 if (flag != NULL)
4c4b4cd2 10809 *flag = 0;
14f9c5c9
AS
10810 return 0;
10811 }
10812 else
10813 {
10814 if (flag != NULL)
4c4b4cd2 10815 *flag = 1;
14f9c5c9
AS
10816 return value_as_long (var_val);
10817 }
10818}
d2e4a39e 10819
14f9c5c9
AS
10820
10821/* Return a range type whose base type is that of the range type named
10822 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 10823 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
10824 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
10825 corresponding range type from debug information; fall back to using it
10826 if symbol lookup fails. If a new type must be created, allocate it
10827 like ORIG_TYPE was. The bounds information, in general, is encoded
10828 in NAME, the base type given in the named range type. */
14f9c5c9 10829
d2e4a39e 10830static struct type *
28c85d6c 10831to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 10832{
0d5cff50 10833 const char *name;
14f9c5c9 10834 struct type *base_type;
d2e4a39e 10835 char *subtype_info;
14f9c5c9 10836
28c85d6c
JB
10837 gdb_assert (raw_type != NULL);
10838 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 10839
1ce677a4 10840 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
10841 base_type = TYPE_TARGET_TYPE (raw_type);
10842 else
10843 base_type = raw_type;
10844
28c85d6c 10845 name = TYPE_NAME (raw_type);
14f9c5c9
AS
10846 subtype_info = strstr (name, "___XD");
10847 if (subtype_info == NULL)
690cc4eb 10848 {
43bbcdc2
PH
10849 LONGEST L = ada_discrete_type_low_bound (raw_type);
10850 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 10851
690cc4eb
PH
10852 if (L < INT_MIN || U > INT_MAX)
10853 return raw_type;
10854 else
28c85d6c 10855 return create_range_type (alloc_type_copy (raw_type), raw_type,
43bbcdc2
PH
10856 ada_discrete_type_low_bound (raw_type),
10857 ada_discrete_type_high_bound (raw_type));
690cc4eb 10858 }
14f9c5c9
AS
10859 else
10860 {
10861 static char *name_buf = NULL;
10862 static size_t name_len = 0;
10863 int prefix_len = subtype_info - name;
10864 LONGEST L, U;
10865 struct type *type;
10866 char *bounds_str;
10867 int n;
10868
10869 GROW_VECT (name_buf, name_len, prefix_len + 5);
10870 strncpy (name_buf, name, prefix_len);
10871 name_buf[prefix_len] = '\0';
10872
10873 subtype_info += 5;
10874 bounds_str = strchr (subtype_info, '_');
10875 n = 1;
10876
d2e4a39e 10877 if (*subtype_info == 'L')
4c4b4cd2
PH
10878 {
10879 if (!ada_scan_number (bounds_str, n, &L, &n)
10880 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
10881 return raw_type;
10882 if (bounds_str[n] == '_')
10883 n += 2;
0963b4bd 10884 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
10885 n += 1;
10886 subtype_info += 1;
10887 }
d2e4a39e 10888 else
4c4b4cd2
PH
10889 {
10890 int ok;
5b4ee69b 10891
4c4b4cd2
PH
10892 strcpy (name_buf + prefix_len, "___L");
10893 L = get_int_var_value (name_buf, &ok);
10894 if (!ok)
10895 {
323e0a4a 10896 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
10897 L = 1;
10898 }
10899 }
14f9c5c9 10900
d2e4a39e 10901 if (*subtype_info == 'U')
4c4b4cd2
PH
10902 {
10903 if (!ada_scan_number (bounds_str, n, &U, &n)
10904 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
10905 return raw_type;
10906 }
d2e4a39e 10907 else
4c4b4cd2
PH
10908 {
10909 int ok;
5b4ee69b 10910
4c4b4cd2
PH
10911 strcpy (name_buf + prefix_len, "___U");
10912 U = get_int_var_value (name_buf, &ok);
10913 if (!ok)
10914 {
323e0a4a 10915 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
10916 U = L;
10917 }
10918 }
14f9c5c9 10919
28c85d6c 10920 type = create_range_type (alloc_type_copy (raw_type), base_type, L, U);
d2e4a39e 10921 TYPE_NAME (type) = name;
14f9c5c9
AS
10922 return type;
10923 }
10924}
10925
4c4b4cd2
PH
10926/* True iff NAME is the name of a range type. */
10927
14f9c5c9 10928int
d2e4a39e 10929ada_is_range_type_name (const char *name)
14f9c5c9
AS
10930{
10931 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 10932}
14f9c5c9 10933\f
d2e4a39e 10934
4c4b4cd2
PH
10935 /* Modular types */
10936
10937/* True iff TYPE is an Ada modular type. */
14f9c5c9 10938
14f9c5c9 10939int
d2e4a39e 10940ada_is_modular_type (struct type *type)
14f9c5c9 10941{
18af8284 10942 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
10943
10944 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 10945 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 10946 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
10947}
10948
4c4b4cd2
PH
10949/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
10950
61ee279c 10951ULONGEST
0056e4d5 10952ada_modulus (struct type *type)
14f9c5c9 10953{
43bbcdc2 10954 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 10955}
d2e4a39e 10956\f
f7f9143b
JB
10957
10958/* Ada exception catchpoint support:
10959 ---------------------------------
10960
10961 We support 3 kinds of exception catchpoints:
10962 . catchpoints on Ada exceptions
10963 . catchpoints on unhandled Ada exceptions
10964 . catchpoints on failed assertions
10965
10966 Exceptions raised during failed assertions, or unhandled exceptions
10967 could perfectly be caught with the general catchpoint on Ada exceptions.
10968 However, we can easily differentiate these two special cases, and having
10969 the option to distinguish these two cases from the rest can be useful
10970 to zero-in on certain situations.
10971
10972 Exception catchpoints are a specialized form of breakpoint,
10973 since they rely on inserting breakpoints inside known routines
10974 of the GNAT runtime. The implementation therefore uses a standard
10975 breakpoint structure of the BP_BREAKPOINT type, but with its own set
10976 of breakpoint_ops.
10977
0259addd
JB
10978 Support in the runtime for exception catchpoints have been changed
10979 a few times already, and these changes affect the implementation
10980 of these catchpoints. In order to be able to support several
10981 variants of the runtime, we use a sniffer that will determine
28010a5d 10982 the runtime variant used by the program being debugged. */
f7f9143b
JB
10983
10984/* The different types of catchpoints that we introduced for catching
10985 Ada exceptions. */
10986
10987enum exception_catchpoint_kind
10988{
10989 ex_catch_exception,
10990 ex_catch_exception_unhandled,
10991 ex_catch_assert
10992};
10993
3d0b0fa3
JB
10994/* Ada's standard exceptions. */
10995
10996static char *standard_exc[] = {
10997 "constraint_error",
10998 "program_error",
10999 "storage_error",
11000 "tasking_error"
11001};
11002
0259addd
JB
11003typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11004
11005/* A structure that describes how to support exception catchpoints
11006 for a given executable. */
11007
11008struct exception_support_info
11009{
11010 /* The name of the symbol to break on in order to insert
11011 a catchpoint on exceptions. */
11012 const char *catch_exception_sym;
11013
11014 /* The name of the symbol to break on in order to insert
11015 a catchpoint on unhandled exceptions. */
11016 const char *catch_exception_unhandled_sym;
11017
11018 /* The name of the symbol to break on in order to insert
11019 a catchpoint on failed assertions. */
11020 const char *catch_assert_sym;
11021
11022 /* Assuming that the inferior just triggered an unhandled exception
11023 catchpoint, this function is responsible for returning the address
11024 in inferior memory where the name of that exception is stored.
11025 Return zero if the address could not be computed. */
11026 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11027};
11028
11029static CORE_ADDR ada_unhandled_exception_name_addr (void);
11030static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11031
11032/* The following exception support info structure describes how to
11033 implement exception catchpoints with the latest version of the
11034 Ada runtime (as of 2007-03-06). */
11035
11036static const struct exception_support_info default_exception_support_info =
11037{
11038 "__gnat_debug_raise_exception", /* catch_exception_sym */
11039 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11040 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11041 ada_unhandled_exception_name_addr
11042};
11043
11044/* The following exception support info structure describes how to
11045 implement exception catchpoints with a slightly older version
11046 of the Ada runtime. */
11047
11048static const struct exception_support_info exception_support_info_fallback =
11049{
11050 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11051 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11052 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11053 ada_unhandled_exception_name_addr_from_raise
11054};
11055
f17011e0
JB
11056/* Return nonzero if we can detect the exception support routines
11057 described in EINFO.
11058
11059 This function errors out if an abnormal situation is detected
11060 (for instance, if we find the exception support routines, but
11061 that support is found to be incomplete). */
11062
11063static int
11064ada_has_this_exception_support (const struct exception_support_info *einfo)
11065{
11066 struct symbol *sym;
11067
11068 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11069 that should be compiled with debugging information. As a result, we
11070 expect to find that symbol in the symtabs. */
11071
11072 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11073 if (sym == NULL)
a6af7abe
JB
11074 {
11075 /* Perhaps we did not find our symbol because the Ada runtime was
11076 compiled without debugging info, or simply stripped of it.
11077 It happens on some GNU/Linux distributions for instance, where
11078 users have to install a separate debug package in order to get
11079 the runtime's debugging info. In that situation, let the user
11080 know why we cannot insert an Ada exception catchpoint.
11081
11082 Note: Just for the purpose of inserting our Ada exception
11083 catchpoint, we could rely purely on the associated minimal symbol.
11084 But we would be operating in degraded mode anyway, since we are
11085 still lacking the debugging info needed later on to extract
11086 the name of the exception being raised (this name is printed in
11087 the catchpoint message, and is also used when trying to catch
11088 a specific exception). We do not handle this case for now. */
1c8e84b0
JB
11089 struct minimal_symbol *msym
11090 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11091
11092 if (msym && MSYMBOL_TYPE (msym) != mst_solib_trampoline)
a6af7abe
JB
11093 error (_("Your Ada runtime appears to be missing some debugging "
11094 "information.\nCannot insert Ada exception catchpoint "
11095 "in this configuration."));
11096
11097 return 0;
11098 }
f17011e0
JB
11099
11100 /* Make sure that the symbol we found corresponds to a function. */
11101
11102 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11103 error (_("Symbol \"%s\" is not a function (class = %d)"),
11104 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11105
11106 return 1;
11107}
11108
0259addd
JB
11109/* Inspect the Ada runtime and determine which exception info structure
11110 should be used to provide support for exception catchpoints.
11111
3eecfa55
JB
11112 This function will always set the per-inferior exception_info,
11113 or raise an error. */
0259addd
JB
11114
11115static void
11116ada_exception_support_info_sniffer (void)
11117{
3eecfa55 11118 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
11119
11120 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 11121 if (data->exception_info != NULL)
0259addd
JB
11122 return;
11123
11124 /* Check the latest (default) exception support info. */
f17011e0 11125 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 11126 {
3eecfa55 11127 data->exception_info = &default_exception_support_info;
0259addd
JB
11128 return;
11129 }
11130
11131 /* Try our fallback exception suport info. */
f17011e0 11132 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 11133 {
3eecfa55 11134 data->exception_info = &exception_support_info_fallback;
0259addd
JB
11135 return;
11136 }
11137
11138 /* Sometimes, it is normal for us to not be able to find the routine
11139 we are looking for. This happens when the program is linked with
11140 the shared version of the GNAT runtime, and the program has not been
11141 started yet. Inform the user of these two possible causes if
11142 applicable. */
11143
ccefe4c4 11144 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
11145 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11146
11147 /* If the symbol does not exist, then check that the program is
11148 already started, to make sure that shared libraries have been
11149 loaded. If it is not started, this may mean that the symbol is
11150 in a shared library. */
11151
11152 if (ptid_get_pid (inferior_ptid) == 0)
11153 error (_("Unable to insert catchpoint. Try to start the program first."));
11154
11155 /* At this point, we know that we are debugging an Ada program and
11156 that the inferior has been started, but we still are not able to
0963b4bd 11157 find the run-time symbols. That can mean that we are in
0259addd
JB
11158 configurable run time mode, or that a-except as been optimized
11159 out by the linker... In any case, at this point it is not worth
11160 supporting this feature. */
11161
7dda8cff 11162 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
11163}
11164
f7f9143b
JB
11165/* True iff FRAME is very likely to be that of a function that is
11166 part of the runtime system. This is all very heuristic, but is
11167 intended to be used as advice as to what frames are uninteresting
11168 to most users. */
11169
11170static int
11171is_known_support_routine (struct frame_info *frame)
11172{
4ed6b5be 11173 struct symtab_and_line sal;
55b87a52 11174 char *func_name;
692465f1 11175 enum language func_lang;
f7f9143b 11176 int i;
f35a17b5 11177 const char *fullname;
f7f9143b 11178
4ed6b5be
JB
11179 /* If this code does not have any debugging information (no symtab),
11180 This cannot be any user code. */
f7f9143b 11181
4ed6b5be 11182 find_frame_sal (frame, &sal);
f7f9143b
JB
11183 if (sal.symtab == NULL)
11184 return 1;
11185
4ed6b5be
JB
11186 /* If there is a symtab, but the associated source file cannot be
11187 located, then assume this is not user code: Selecting a frame
11188 for which we cannot display the code would not be very helpful
11189 for the user. This should also take care of case such as VxWorks
11190 where the kernel has some debugging info provided for a few units. */
f7f9143b 11191
f35a17b5
JK
11192 fullname = symtab_to_fullname (sal.symtab);
11193 if (access (fullname, R_OK) != 0)
f7f9143b
JB
11194 return 1;
11195
4ed6b5be
JB
11196 /* Check the unit filename againt the Ada runtime file naming.
11197 We also check the name of the objfile against the name of some
11198 known system libraries that sometimes come with debugging info
11199 too. */
11200
f7f9143b
JB
11201 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11202 {
11203 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 11204 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 11205 return 1;
4ed6b5be 11206 if (sal.symtab->objfile != NULL
4262abfb 11207 && re_exec (objfile_name (sal.symtab->objfile)))
4ed6b5be 11208 return 1;
f7f9143b
JB
11209 }
11210
4ed6b5be 11211 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 11212
e9e07ba6 11213 find_frame_funname (frame, &func_name, &func_lang, NULL);
f7f9143b
JB
11214 if (func_name == NULL)
11215 return 1;
11216
11217 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11218 {
11219 re_comp (known_auxiliary_function_name_patterns[i]);
11220 if (re_exec (func_name))
55b87a52
KS
11221 {
11222 xfree (func_name);
11223 return 1;
11224 }
f7f9143b
JB
11225 }
11226
55b87a52 11227 xfree (func_name);
f7f9143b
JB
11228 return 0;
11229}
11230
11231/* Find the first frame that contains debugging information and that is not
11232 part of the Ada run-time, starting from FI and moving upward. */
11233
0ef643c8 11234void
f7f9143b
JB
11235ada_find_printable_frame (struct frame_info *fi)
11236{
11237 for (; fi != NULL; fi = get_prev_frame (fi))
11238 {
11239 if (!is_known_support_routine (fi))
11240 {
11241 select_frame (fi);
11242 break;
11243 }
11244 }
11245
11246}
11247
11248/* Assuming that the inferior just triggered an unhandled exception
11249 catchpoint, return the address in inferior memory where the name
11250 of the exception is stored.
11251
11252 Return zero if the address could not be computed. */
11253
11254static CORE_ADDR
11255ada_unhandled_exception_name_addr (void)
0259addd
JB
11256{
11257 return parse_and_eval_address ("e.full_name");
11258}
11259
11260/* Same as ada_unhandled_exception_name_addr, except that this function
11261 should be used when the inferior uses an older version of the runtime,
11262 where the exception name needs to be extracted from a specific frame
11263 several frames up in the callstack. */
11264
11265static CORE_ADDR
11266ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
11267{
11268 int frame_level;
11269 struct frame_info *fi;
3eecfa55 11270 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
55b87a52 11271 struct cleanup *old_chain;
f7f9143b
JB
11272
11273 /* To determine the name of this exception, we need to select
11274 the frame corresponding to RAISE_SYM_NAME. This frame is
11275 at least 3 levels up, so we simply skip the first 3 frames
11276 without checking the name of their associated function. */
11277 fi = get_current_frame ();
11278 for (frame_level = 0; frame_level < 3; frame_level += 1)
11279 if (fi != NULL)
11280 fi = get_prev_frame (fi);
11281
55b87a52 11282 old_chain = make_cleanup (null_cleanup, NULL);
f7f9143b
JB
11283 while (fi != NULL)
11284 {
55b87a52 11285 char *func_name;
692465f1
JB
11286 enum language func_lang;
11287
e9e07ba6 11288 find_frame_funname (fi, &func_name, &func_lang, NULL);
55b87a52
KS
11289 if (func_name != NULL)
11290 {
11291 make_cleanup (xfree, func_name);
11292
11293 if (strcmp (func_name,
11294 data->exception_info->catch_exception_sym) == 0)
11295 break; /* We found the frame we were looking for... */
11296 fi = get_prev_frame (fi);
11297 }
f7f9143b 11298 }
55b87a52 11299 do_cleanups (old_chain);
f7f9143b
JB
11300
11301 if (fi == NULL)
11302 return 0;
11303
11304 select_frame (fi);
11305 return parse_and_eval_address ("id.full_name");
11306}
11307
11308/* Assuming the inferior just triggered an Ada exception catchpoint
11309 (of any type), return the address in inferior memory where the name
11310 of the exception is stored, if applicable.
11311
11312 Return zero if the address could not be computed, or if not relevant. */
11313
11314static CORE_ADDR
11315ada_exception_name_addr_1 (enum exception_catchpoint_kind ex,
11316 struct breakpoint *b)
11317{
3eecfa55
JB
11318 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11319
f7f9143b
JB
11320 switch (ex)
11321 {
11322 case ex_catch_exception:
11323 return (parse_and_eval_address ("e.full_name"));
11324 break;
11325
11326 case ex_catch_exception_unhandled:
3eecfa55 11327 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
11328 break;
11329
11330 case ex_catch_assert:
11331 return 0; /* Exception name is not relevant in this case. */
11332 break;
11333
11334 default:
11335 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11336 break;
11337 }
11338
11339 return 0; /* Should never be reached. */
11340}
11341
11342/* Same as ada_exception_name_addr_1, except that it intercepts and contains
11343 any error that ada_exception_name_addr_1 might cause to be thrown.
11344 When an error is intercepted, a warning with the error message is printed,
11345 and zero is returned. */
11346
11347static CORE_ADDR
11348ada_exception_name_addr (enum exception_catchpoint_kind ex,
11349 struct breakpoint *b)
11350{
bfd189b1 11351 volatile struct gdb_exception e;
f7f9143b
JB
11352 CORE_ADDR result = 0;
11353
11354 TRY_CATCH (e, RETURN_MASK_ERROR)
11355 {
11356 result = ada_exception_name_addr_1 (ex, b);
11357 }
11358
11359 if (e.reason < 0)
11360 {
11361 warning (_("failed to get exception name: %s"), e.message);
11362 return 0;
11363 }
11364
11365 return result;
11366}
11367
28010a5d
PA
11368static char *ada_exception_catchpoint_cond_string (const char *excep_string);
11369
11370/* Ada catchpoints.
11371
11372 In the case of catchpoints on Ada exceptions, the catchpoint will
11373 stop the target on every exception the program throws. When a user
11374 specifies the name of a specific exception, we translate this
11375 request into a condition expression (in text form), and then parse
11376 it into an expression stored in each of the catchpoint's locations.
11377 We then use this condition to check whether the exception that was
11378 raised is the one the user is interested in. If not, then the
11379 target is resumed again. We store the name of the requested
11380 exception, in order to be able to re-set the condition expression
11381 when symbols change. */
11382
11383/* An instance of this type is used to represent an Ada catchpoint
11384 breakpoint location. It includes a "struct bp_location" as a kind
11385 of base class; users downcast to "struct bp_location *" when
11386 needed. */
11387
11388struct ada_catchpoint_location
11389{
11390 /* The base class. */
11391 struct bp_location base;
11392
11393 /* The condition that checks whether the exception that was raised
11394 is the specific exception the user specified on catchpoint
11395 creation. */
11396 struct expression *excep_cond_expr;
11397};
11398
11399/* Implement the DTOR method in the bp_location_ops structure for all
11400 Ada exception catchpoint kinds. */
11401
11402static void
11403ada_catchpoint_location_dtor (struct bp_location *bl)
11404{
11405 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
11406
11407 xfree (al->excep_cond_expr);
11408}
11409
11410/* The vtable to be used in Ada catchpoint locations. */
11411
11412static const struct bp_location_ops ada_catchpoint_location_ops =
11413{
11414 ada_catchpoint_location_dtor
11415};
11416
11417/* An instance of this type is used to represent an Ada catchpoint.
11418 It includes a "struct breakpoint" as a kind of base class; users
11419 downcast to "struct breakpoint *" when needed. */
11420
11421struct ada_catchpoint
11422{
11423 /* The base class. */
11424 struct breakpoint base;
11425
11426 /* The name of the specific exception the user specified. */
11427 char *excep_string;
11428};
11429
11430/* Parse the exception condition string in the context of each of the
11431 catchpoint's locations, and store them for later evaluation. */
11432
11433static void
11434create_excep_cond_exprs (struct ada_catchpoint *c)
11435{
11436 struct cleanup *old_chain;
11437 struct bp_location *bl;
11438 char *cond_string;
11439
11440 /* Nothing to do if there's no specific exception to catch. */
11441 if (c->excep_string == NULL)
11442 return;
11443
11444 /* Same if there are no locations... */
11445 if (c->base.loc == NULL)
11446 return;
11447
11448 /* Compute the condition expression in text form, from the specific
11449 expection we want to catch. */
11450 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
11451 old_chain = make_cleanup (xfree, cond_string);
11452
11453 /* Iterate over all the catchpoint's locations, and parse an
11454 expression for each. */
11455 for (bl = c->base.loc; bl != NULL; bl = bl->next)
11456 {
11457 struct ada_catchpoint_location *ada_loc
11458 = (struct ada_catchpoint_location *) bl;
11459 struct expression *exp = NULL;
11460
11461 if (!bl->shlib_disabled)
11462 {
11463 volatile struct gdb_exception e;
bbc13ae3 11464 const char *s;
28010a5d
PA
11465
11466 s = cond_string;
11467 TRY_CATCH (e, RETURN_MASK_ERROR)
11468 {
1bb9788d
TT
11469 exp = parse_exp_1 (&s, bl->address,
11470 block_for_pc (bl->address), 0);
28010a5d
PA
11471 }
11472 if (e.reason < 0)
11473 warning (_("failed to reevaluate internal exception condition "
11474 "for catchpoint %d: %s"),
11475 c->base.number, e.message);
11476 }
11477
11478 ada_loc->excep_cond_expr = exp;
11479 }
11480
11481 do_cleanups (old_chain);
11482}
11483
11484/* Implement the DTOR method in the breakpoint_ops structure for all
11485 exception catchpoint kinds. */
11486
11487static void
11488dtor_exception (enum exception_catchpoint_kind ex, struct breakpoint *b)
11489{
11490 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11491
11492 xfree (c->excep_string);
348d480f 11493
2060206e 11494 bkpt_breakpoint_ops.dtor (b);
28010a5d
PA
11495}
11496
11497/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11498 structure for all exception catchpoint kinds. */
11499
11500static struct bp_location *
11501allocate_location_exception (enum exception_catchpoint_kind ex,
11502 struct breakpoint *self)
11503{
11504 struct ada_catchpoint_location *loc;
11505
11506 loc = XNEW (struct ada_catchpoint_location);
11507 init_bp_location (&loc->base, &ada_catchpoint_location_ops, self);
11508 loc->excep_cond_expr = NULL;
11509 return &loc->base;
11510}
11511
11512/* Implement the RE_SET method in the breakpoint_ops structure for all
11513 exception catchpoint kinds. */
11514
11515static void
11516re_set_exception (enum exception_catchpoint_kind ex, struct breakpoint *b)
11517{
11518 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11519
11520 /* Call the base class's method. This updates the catchpoint's
11521 locations. */
2060206e 11522 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
11523
11524 /* Reparse the exception conditional expressions. One for each
11525 location. */
11526 create_excep_cond_exprs (c);
11527}
11528
11529/* Returns true if we should stop for this breakpoint hit. If the
11530 user specified a specific exception, we only want to cause a stop
11531 if the program thrown that exception. */
11532
11533static int
11534should_stop_exception (const struct bp_location *bl)
11535{
11536 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11537 const struct ada_catchpoint_location *ada_loc
11538 = (const struct ada_catchpoint_location *) bl;
11539 volatile struct gdb_exception ex;
11540 int stop;
11541
11542 /* With no specific exception, should always stop. */
11543 if (c->excep_string == NULL)
11544 return 1;
11545
11546 if (ada_loc->excep_cond_expr == NULL)
11547 {
11548 /* We will have a NULL expression if back when we were creating
11549 the expressions, this location's had failed to parse. */
11550 return 1;
11551 }
11552
11553 stop = 1;
11554 TRY_CATCH (ex, RETURN_MASK_ALL)
11555 {
11556 struct value *mark;
11557
11558 mark = value_mark ();
11559 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr));
11560 value_free_to_mark (mark);
11561 }
11562 if (ex.reason < 0)
11563 exception_fprintf (gdb_stderr, ex,
11564 _("Error in testing exception condition:\n"));
11565 return stop;
11566}
11567
11568/* Implement the CHECK_STATUS method in the breakpoint_ops structure
11569 for all exception catchpoint kinds. */
11570
11571static void
11572check_status_exception (enum exception_catchpoint_kind ex, bpstat bs)
11573{
11574 bs->stop = should_stop_exception (bs->bp_location_at);
11575}
11576
f7f9143b
JB
11577/* Implement the PRINT_IT method in the breakpoint_ops structure
11578 for all exception catchpoint kinds. */
11579
11580static enum print_stop_action
348d480f 11581print_it_exception (enum exception_catchpoint_kind ex, bpstat bs)
f7f9143b 11582{
79a45e25 11583 struct ui_out *uiout = current_uiout;
348d480f
PA
11584 struct breakpoint *b = bs->breakpoint_at;
11585
956a9fb9 11586 annotate_catchpoint (b->number);
f7f9143b 11587
956a9fb9 11588 if (ui_out_is_mi_like_p (uiout))
f7f9143b 11589 {
956a9fb9
JB
11590 ui_out_field_string (uiout, "reason",
11591 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11592 ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition));
f7f9143b
JB
11593 }
11594
00eb2c4a
JB
11595 ui_out_text (uiout,
11596 b->disposition == disp_del ? "\nTemporary catchpoint "
11597 : "\nCatchpoint ");
956a9fb9
JB
11598 ui_out_field_int (uiout, "bkptno", b->number);
11599 ui_out_text (uiout, ", ");
f7f9143b 11600
f7f9143b
JB
11601 switch (ex)
11602 {
11603 case ex_catch_exception:
f7f9143b 11604 case ex_catch_exception_unhandled:
956a9fb9
JB
11605 {
11606 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
11607 char exception_name[256];
11608
11609 if (addr != 0)
11610 {
c714b426
PA
11611 read_memory (addr, (gdb_byte *) exception_name,
11612 sizeof (exception_name) - 1);
956a9fb9
JB
11613 exception_name [sizeof (exception_name) - 1] = '\0';
11614 }
11615 else
11616 {
11617 /* For some reason, we were unable to read the exception
11618 name. This could happen if the Runtime was compiled
11619 without debugging info, for instance. In that case,
11620 just replace the exception name by the generic string
11621 "exception" - it will read as "an exception" in the
11622 notification we are about to print. */
967cff16 11623 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
11624 }
11625 /* In the case of unhandled exception breakpoints, we print
11626 the exception name as "unhandled EXCEPTION_NAME", to make
11627 it clearer to the user which kind of catchpoint just got
11628 hit. We used ui_out_text to make sure that this extra
11629 info does not pollute the exception name in the MI case. */
11630 if (ex == ex_catch_exception_unhandled)
11631 ui_out_text (uiout, "unhandled ");
11632 ui_out_field_string (uiout, "exception-name", exception_name);
11633 }
11634 break;
f7f9143b 11635 case ex_catch_assert:
956a9fb9
JB
11636 /* In this case, the name of the exception is not really
11637 important. Just print "failed assertion" to make it clearer
11638 that his program just hit an assertion-failure catchpoint.
11639 We used ui_out_text because this info does not belong in
11640 the MI output. */
11641 ui_out_text (uiout, "failed assertion");
11642 break;
f7f9143b 11643 }
956a9fb9
JB
11644 ui_out_text (uiout, " at ");
11645 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
11646
11647 return PRINT_SRC_AND_LOC;
11648}
11649
11650/* Implement the PRINT_ONE method in the breakpoint_ops structure
11651 for all exception catchpoint kinds. */
11652
11653static void
11654print_one_exception (enum exception_catchpoint_kind ex,
a6d9a66e 11655 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11656{
79a45e25 11657 struct ui_out *uiout = current_uiout;
28010a5d 11658 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
11659 struct value_print_options opts;
11660
11661 get_user_print_options (&opts);
11662 if (opts.addressprint)
f7f9143b
JB
11663 {
11664 annotate_field (4);
5af949e3 11665 ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
11666 }
11667
11668 annotate_field (5);
a6d9a66e 11669 *last_loc = b->loc;
f7f9143b
JB
11670 switch (ex)
11671 {
11672 case ex_catch_exception:
28010a5d 11673 if (c->excep_string != NULL)
f7f9143b 11674 {
28010a5d
PA
11675 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11676
f7f9143b
JB
11677 ui_out_field_string (uiout, "what", msg);
11678 xfree (msg);
11679 }
11680 else
11681 ui_out_field_string (uiout, "what", "all Ada exceptions");
11682
11683 break;
11684
11685 case ex_catch_exception_unhandled:
11686 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
11687 break;
11688
11689 case ex_catch_assert:
11690 ui_out_field_string (uiout, "what", "failed Ada assertions");
11691 break;
11692
11693 default:
11694 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11695 break;
11696 }
11697}
11698
11699/* Implement the PRINT_MENTION method in the breakpoint_ops structure
11700 for all exception catchpoint kinds. */
11701
11702static void
11703print_mention_exception (enum exception_catchpoint_kind ex,
11704 struct breakpoint *b)
11705{
28010a5d 11706 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 11707 struct ui_out *uiout = current_uiout;
28010a5d 11708
00eb2c4a
JB
11709 ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ")
11710 : _("Catchpoint "));
11711 ui_out_field_int (uiout, "bkptno", b->number);
11712 ui_out_text (uiout, ": ");
11713
f7f9143b
JB
11714 switch (ex)
11715 {
11716 case ex_catch_exception:
28010a5d 11717 if (c->excep_string != NULL)
00eb2c4a
JB
11718 {
11719 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11720 struct cleanup *old_chain = make_cleanup (xfree, info);
11721
11722 ui_out_text (uiout, info);
11723 do_cleanups (old_chain);
11724 }
f7f9143b 11725 else
00eb2c4a 11726 ui_out_text (uiout, _("all Ada exceptions"));
f7f9143b
JB
11727 break;
11728
11729 case ex_catch_exception_unhandled:
00eb2c4a 11730 ui_out_text (uiout, _("unhandled Ada exceptions"));
f7f9143b
JB
11731 break;
11732
11733 case ex_catch_assert:
00eb2c4a 11734 ui_out_text (uiout, _("failed Ada assertions"));
f7f9143b
JB
11735 break;
11736
11737 default:
11738 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11739 break;
11740 }
11741}
11742
6149aea9
PA
11743/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
11744 for all exception catchpoint kinds. */
11745
11746static void
11747print_recreate_exception (enum exception_catchpoint_kind ex,
11748 struct breakpoint *b, struct ui_file *fp)
11749{
28010a5d
PA
11750 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11751
6149aea9
PA
11752 switch (ex)
11753 {
11754 case ex_catch_exception:
11755 fprintf_filtered (fp, "catch exception");
28010a5d
PA
11756 if (c->excep_string != NULL)
11757 fprintf_filtered (fp, " %s", c->excep_string);
6149aea9
PA
11758 break;
11759
11760 case ex_catch_exception_unhandled:
78076abc 11761 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
11762 break;
11763
11764 case ex_catch_assert:
11765 fprintf_filtered (fp, "catch assert");
11766 break;
11767
11768 default:
11769 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11770 }
d9b3f62e 11771 print_recreate_thread (b, fp);
6149aea9
PA
11772}
11773
f7f9143b
JB
11774/* Virtual table for "catch exception" breakpoints. */
11775
28010a5d
PA
11776static void
11777dtor_catch_exception (struct breakpoint *b)
11778{
11779 dtor_exception (ex_catch_exception, b);
11780}
11781
11782static struct bp_location *
11783allocate_location_catch_exception (struct breakpoint *self)
11784{
11785 return allocate_location_exception (ex_catch_exception, self);
11786}
11787
11788static void
11789re_set_catch_exception (struct breakpoint *b)
11790{
11791 re_set_exception (ex_catch_exception, b);
11792}
11793
11794static void
11795check_status_catch_exception (bpstat bs)
11796{
11797 check_status_exception (ex_catch_exception, bs);
11798}
11799
f7f9143b 11800static enum print_stop_action
348d480f 11801print_it_catch_exception (bpstat bs)
f7f9143b 11802{
348d480f 11803 return print_it_exception (ex_catch_exception, bs);
f7f9143b
JB
11804}
11805
11806static void
a6d9a66e 11807print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11808{
a6d9a66e 11809 print_one_exception (ex_catch_exception, b, last_loc);
f7f9143b
JB
11810}
11811
11812static void
11813print_mention_catch_exception (struct breakpoint *b)
11814{
11815 print_mention_exception (ex_catch_exception, b);
11816}
11817
6149aea9
PA
11818static void
11819print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
11820{
11821 print_recreate_exception (ex_catch_exception, b, fp);
11822}
11823
2060206e 11824static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
11825
11826/* Virtual table for "catch exception unhandled" breakpoints. */
11827
28010a5d
PA
11828static void
11829dtor_catch_exception_unhandled (struct breakpoint *b)
11830{
11831 dtor_exception (ex_catch_exception_unhandled, b);
11832}
11833
11834static struct bp_location *
11835allocate_location_catch_exception_unhandled (struct breakpoint *self)
11836{
11837 return allocate_location_exception (ex_catch_exception_unhandled, self);
11838}
11839
11840static void
11841re_set_catch_exception_unhandled (struct breakpoint *b)
11842{
11843 re_set_exception (ex_catch_exception_unhandled, b);
11844}
11845
11846static void
11847check_status_catch_exception_unhandled (bpstat bs)
11848{
11849 check_status_exception (ex_catch_exception_unhandled, bs);
11850}
11851
f7f9143b 11852static enum print_stop_action
348d480f 11853print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 11854{
348d480f 11855 return print_it_exception (ex_catch_exception_unhandled, bs);
f7f9143b
JB
11856}
11857
11858static void
a6d9a66e
UW
11859print_one_catch_exception_unhandled (struct breakpoint *b,
11860 struct bp_location **last_loc)
f7f9143b 11861{
a6d9a66e 11862 print_one_exception (ex_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
11863}
11864
11865static void
11866print_mention_catch_exception_unhandled (struct breakpoint *b)
11867{
11868 print_mention_exception (ex_catch_exception_unhandled, b);
11869}
11870
6149aea9
PA
11871static void
11872print_recreate_catch_exception_unhandled (struct breakpoint *b,
11873 struct ui_file *fp)
11874{
11875 print_recreate_exception (ex_catch_exception_unhandled, b, fp);
11876}
11877
2060206e 11878static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
11879
11880/* Virtual table for "catch assert" breakpoints. */
11881
28010a5d
PA
11882static void
11883dtor_catch_assert (struct breakpoint *b)
11884{
11885 dtor_exception (ex_catch_assert, b);
11886}
11887
11888static struct bp_location *
11889allocate_location_catch_assert (struct breakpoint *self)
11890{
11891 return allocate_location_exception (ex_catch_assert, self);
11892}
11893
11894static void
11895re_set_catch_assert (struct breakpoint *b)
11896{
843e694d 11897 re_set_exception (ex_catch_assert, b);
28010a5d
PA
11898}
11899
11900static void
11901check_status_catch_assert (bpstat bs)
11902{
11903 check_status_exception (ex_catch_assert, bs);
11904}
11905
f7f9143b 11906static enum print_stop_action
348d480f 11907print_it_catch_assert (bpstat bs)
f7f9143b 11908{
348d480f 11909 return print_it_exception (ex_catch_assert, bs);
f7f9143b
JB
11910}
11911
11912static void
a6d9a66e 11913print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11914{
a6d9a66e 11915 print_one_exception (ex_catch_assert, b, last_loc);
f7f9143b
JB
11916}
11917
11918static void
11919print_mention_catch_assert (struct breakpoint *b)
11920{
11921 print_mention_exception (ex_catch_assert, b);
11922}
11923
6149aea9
PA
11924static void
11925print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
11926{
11927 print_recreate_exception (ex_catch_assert, b, fp);
11928}
11929
2060206e 11930static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 11931
f7f9143b
JB
11932/* Return a newly allocated copy of the first space-separated token
11933 in ARGSP, and then adjust ARGSP to point immediately after that
11934 token.
11935
11936 Return NULL if ARGPS does not contain any more tokens. */
11937
11938static char *
11939ada_get_next_arg (char **argsp)
11940{
11941 char *args = *argsp;
11942 char *end;
11943 char *result;
11944
0fcd72ba 11945 args = skip_spaces (args);
f7f9143b
JB
11946 if (args[0] == '\0')
11947 return NULL; /* No more arguments. */
11948
11949 /* Find the end of the current argument. */
11950
0fcd72ba 11951 end = skip_to_space (args);
f7f9143b
JB
11952
11953 /* Adjust ARGSP to point to the start of the next argument. */
11954
11955 *argsp = end;
11956
11957 /* Make a copy of the current argument and return it. */
11958
11959 result = xmalloc (end - args + 1);
11960 strncpy (result, args, end - args);
11961 result[end - args] = '\0';
11962
11963 return result;
11964}
11965
11966/* Split the arguments specified in a "catch exception" command.
11967 Set EX to the appropriate catchpoint type.
28010a5d 11968 Set EXCEP_STRING to the name of the specific exception if
5845583d
JB
11969 specified by the user.
11970 If a condition is found at the end of the arguments, the condition
11971 expression is stored in COND_STRING (memory must be deallocated
11972 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
11973
11974static void
11975catch_ada_exception_command_split (char *args,
11976 enum exception_catchpoint_kind *ex,
5845583d
JB
11977 char **excep_string,
11978 char **cond_string)
f7f9143b
JB
11979{
11980 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
11981 char *exception_name;
5845583d 11982 char *cond = NULL;
f7f9143b
JB
11983
11984 exception_name = ada_get_next_arg (&args);
5845583d
JB
11985 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
11986 {
11987 /* This is not an exception name; this is the start of a condition
11988 expression for a catchpoint on all exceptions. So, "un-get"
11989 this token, and set exception_name to NULL. */
11990 xfree (exception_name);
11991 exception_name = NULL;
11992 args -= 2;
11993 }
f7f9143b
JB
11994 make_cleanup (xfree, exception_name);
11995
5845583d 11996 /* Check to see if we have a condition. */
f7f9143b 11997
0fcd72ba 11998 args = skip_spaces (args);
5845583d
JB
11999 if (strncmp (args, "if", 2) == 0
12000 && (isspace (args[2]) || args[2] == '\0'))
12001 {
12002 args += 2;
12003 args = skip_spaces (args);
12004
12005 if (args[0] == '\0')
12006 error (_("Condition missing after `if' keyword"));
12007 cond = xstrdup (args);
12008 make_cleanup (xfree, cond);
12009
12010 args += strlen (args);
12011 }
12012
12013 /* Check that we do not have any more arguments. Anything else
12014 is unexpected. */
f7f9143b
JB
12015
12016 if (args[0] != '\0')
12017 error (_("Junk at end of expression"));
12018
12019 discard_cleanups (old_chain);
12020
12021 if (exception_name == NULL)
12022 {
12023 /* Catch all exceptions. */
12024 *ex = ex_catch_exception;
28010a5d 12025 *excep_string = NULL;
f7f9143b
JB
12026 }
12027 else if (strcmp (exception_name, "unhandled") == 0)
12028 {
12029 /* Catch unhandled exceptions. */
12030 *ex = ex_catch_exception_unhandled;
28010a5d 12031 *excep_string = NULL;
f7f9143b
JB
12032 }
12033 else
12034 {
12035 /* Catch a specific exception. */
12036 *ex = ex_catch_exception;
28010a5d 12037 *excep_string = exception_name;
f7f9143b 12038 }
5845583d 12039 *cond_string = cond;
f7f9143b
JB
12040}
12041
12042/* Return the name of the symbol on which we should break in order to
12043 implement a catchpoint of the EX kind. */
12044
12045static const char *
12046ada_exception_sym_name (enum exception_catchpoint_kind ex)
12047{
3eecfa55
JB
12048 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12049
12050 gdb_assert (data->exception_info != NULL);
0259addd 12051
f7f9143b
JB
12052 switch (ex)
12053 {
12054 case ex_catch_exception:
3eecfa55 12055 return (data->exception_info->catch_exception_sym);
f7f9143b
JB
12056 break;
12057 case ex_catch_exception_unhandled:
3eecfa55 12058 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b
JB
12059 break;
12060 case ex_catch_assert:
3eecfa55 12061 return (data->exception_info->catch_assert_sym);
f7f9143b
JB
12062 break;
12063 default:
12064 internal_error (__FILE__, __LINE__,
12065 _("unexpected catchpoint kind (%d)"), ex);
12066 }
12067}
12068
12069/* Return the breakpoint ops "virtual table" used for catchpoints
12070 of the EX kind. */
12071
c0a91b2b 12072static const struct breakpoint_ops *
4b9eee8c 12073ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex)
f7f9143b
JB
12074{
12075 switch (ex)
12076 {
12077 case ex_catch_exception:
12078 return (&catch_exception_breakpoint_ops);
12079 break;
12080 case ex_catch_exception_unhandled:
12081 return (&catch_exception_unhandled_breakpoint_ops);
12082 break;
12083 case ex_catch_assert:
12084 return (&catch_assert_breakpoint_ops);
12085 break;
12086 default:
12087 internal_error (__FILE__, __LINE__,
12088 _("unexpected catchpoint kind (%d)"), ex);
12089 }
12090}
12091
12092/* Return the condition that will be used to match the current exception
12093 being raised with the exception that the user wants to catch. This
12094 assumes that this condition is used when the inferior just triggered
12095 an exception catchpoint.
12096
12097 The string returned is a newly allocated string that needs to be
12098 deallocated later. */
12099
12100static char *
28010a5d 12101ada_exception_catchpoint_cond_string (const char *excep_string)
f7f9143b 12102{
3d0b0fa3
JB
12103 int i;
12104
0963b4bd 12105 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 12106 runtime units that have been compiled without debugging info; if
28010a5d 12107 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
12108 exception (e.g. "constraint_error") then, during the evaluation
12109 of the condition expression, the symbol lookup on this name would
0963b4bd 12110 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
12111 may then be set only on user-defined exceptions which have the
12112 same not-fully-qualified name (e.g. my_package.constraint_error).
12113
12114 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 12115 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
12116 exception constraint_error" is rewritten into "catch exception
12117 standard.constraint_error".
12118
12119 If an exception named contraint_error is defined in another package of
12120 the inferior program, then the only way to specify this exception as a
12121 breakpoint condition is to use its fully-qualified named:
12122 e.g. my_package.constraint_error. */
12123
12124 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12125 {
28010a5d 12126 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3
JB
12127 {
12128 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
28010a5d 12129 excep_string);
3d0b0fa3
JB
12130 }
12131 }
28010a5d 12132 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
f7f9143b
JB
12133}
12134
12135/* Return the symtab_and_line that should be used to insert an exception
12136 catchpoint of the TYPE kind.
12137
28010a5d
PA
12138 EXCEP_STRING should contain the name of a specific exception that
12139 the catchpoint should catch, or NULL otherwise.
f7f9143b 12140
28010a5d
PA
12141 ADDR_STRING returns the name of the function where the real
12142 breakpoint that implements the catchpoints is set, depending on the
12143 type of catchpoint we need to create. */
f7f9143b
JB
12144
12145static struct symtab_and_line
28010a5d 12146ada_exception_sal (enum exception_catchpoint_kind ex, char *excep_string,
c0a91b2b 12147 char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
12148{
12149 const char *sym_name;
12150 struct symbol *sym;
f7f9143b 12151
0259addd
JB
12152 /* First, find out which exception support info to use. */
12153 ada_exception_support_info_sniffer ();
12154
12155 /* Then lookup the function on which we will break in order to catch
f7f9143b 12156 the Ada exceptions requested by the user. */
f7f9143b
JB
12157 sym_name = ada_exception_sym_name (ex);
12158 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12159
f17011e0
JB
12160 /* We can assume that SYM is not NULL at this stage. If the symbol
12161 did not exist, ada_exception_support_info_sniffer would have
12162 raised an exception.
f7f9143b 12163
f17011e0
JB
12164 Also, ada_exception_support_info_sniffer should have already
12165 verified that SYM is a function symbol. */
12166 gdb_assert (sym != NULL);
12167 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
12168
12169 /* Set ADDR_STRING. */
f7f9143b
JB
12170 *addr_string = xstrdup (sym_name);
12171
f7f9143b 12172 /* Set OPS. */
4b9eee8c 12173 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 12174
f17011e0 12175 return find_function_start_sal (sym, 1);
f7f9143b
JB
12176}
12177
12178/* Parse the arguments (ARGS) of the "catch exception" command.
12179
f7f9143b
JB
12180 If the user asked the catchpoint to catch only a specific
12181 exception, then save the exception name in ADDR_STRING.
12182
5845583d
JB
12183 If the user provided a condition, then set COND_STRING to
12184 that condition expression (the memory must be deallocated
12185 after use). Otherwise, set COND_STRING to NULL.
12186
f7f9143b
JB
12187 See ada_exception_sal for a description of all the remaining
12188 function arguments of this function. */
12189
9ac4176b 12190static struct symtab_and_line
f7f9143b 12191ada_decode_exception_location (char *args, char **addr_string,
28010a5d 12192 char **excep_string,
5845583d 12193 char **cond_string,
c0a91b2b 12194 const struct breakpoint_ops **ops)
f7f9143b
JB
12195{
12196 enum exception_catchpoint_kind ex;
12197
5845583d 12198 catch_ada_exception_command_split (args, &ex, excep_string, cond_string);
28010a5d
PA
12199 return ada_exception_sal (ex, *excep_string, addr_string, ops);
12200}
12201
12202/* Create an Ada exception catchpoint. */
12203
12204static void
12205create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12206 struct symtab_and_line sal,
12207 char *addr_string,
12208 char *excep_string,
5845583d 12209 char *cond_string,
c0a91b2b 12210 const struct breakpoint_ops *ops,
28010a5d
PA
12211 int tempflag,
12212 int from_tty)
12213{
12214 struct ada_catchpoint *c;
12215
12216 c = XNEW (struct ada_catchpoint);
12217 init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string,
12218 ops, tempflag, from_tty);
12219 c->excep_string = excep_string;
12220 create_excep_cond_exprs (c);
5845583d
JB
12221 if (cond_string != NULL)
12222 set_breakpoint_condition (&c->base, cond_string, from_tty);
3ea46bff 12223 install_breakpoint (0, &c->base, 1);
f7f9143b
JB
12224}
12225
9ac4176b
PA
12226/* Implement the "catch exception" command. */
12227
12228static void
12229catch_ada_exception_command (char *arg, int from_tty,
12230 struct cmd_list_element *command)
12231{
12232 struct gdbarch *gdbarch = get_current_arch ();
12233 int tempflag;
12234 struct symtab_and_line sal;
12235 char *addr_string = NULL;
28010a5d 12236 char *excep_string = NULL;
5845583d 12237 char *cond_string = NULL;
c0a91b2b 12238 const struct breakpoint_ops *ops = NULL;
9ac4176b
PA
12239
12240 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12241
12242 if (!arg)
12243 arg = "";
5845583d
JB
12244 sal = ada_decode_exception_location (arg, &addr_string, &excep_string,
12245 &cond_string, &ops);
28010a5d 12246 create_ada_exception_catchpoint (gdbarch, sal, addr_string,
5845583d
JB
12247 excep_string, cond_string, ops,
12248 tempflag, from_tty);
9ac4176b
PA
12249}
12250
5845583d
JB
12251/* Assuming that ARGS contains the arguments of a "catch assert"
12252 command, parse those arguments and return a symtab_and_line object
12253 for a failed assertion catchpoint.
12254
12255 Set ADDR_STRING to the name of the function where the real
12256 breakpoint that implements the catchpoint is set.
12257
12258 If ARGS contains a condition, set COND_STRING to that condition
12259 (the memory needs to be deallocated after use). Otherwise, set
12260 COND_STRING to NULL. */
12261
9ac4176b 12262static struct symtab_and_line
f7f9143b 12263ada_decode_assert_location (char *args, char **addr_string,
5845583d 12264 char **cond_string,
c0a91b2b 12265 const struct breakpoint_ops **ops)
f7f9143b 12266{
5845583d 12267 args = skip_spaces (args);
f7f9143b 12268
5845583d
JB
12269 /* Check whether a condition was provided. */
12270 if (strncmp (args, "if", 2) == 0
12271 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 12272 {
5845583d 12273 args += 2;
0fcd72ba 12274 args = skip_spaces (args);
5845583d
JB
12275 if (args[0] == '\0')
12276 error (_("condition missing after `if' keyword"));
12277 *cond_string = xstrdup (args);
f7f9143b
JB
12278 }
12279
5845583d
JB
12280 /* Otherwise, there should be no other argument at the end of
12281 the command. */
12282 else if (args[0] != '\0')
12283 error (_("Junk at end of arguments."));
12284
28010a5d 12285 return ada_exception_sal (ex_catch_assert, NULL, addr_string, ops);
f7f9143b
JB
12286}
12287
9ac4176b
PA
12288/* Implement the "catch assert" command. */
12289
12290static void
12291catch_assert_command (char *arg, int from_tty,
12292 struct cmd_list_element *command)
12293{
12294 struct gdbarch *gdbarch = get_current_arch ();
12295 int tempflag;
12296 struct symtab_and_line sal;
12297 char *addr_string = NULL;
5845583d 12298 char *cond_string = NULL;
c0a91b2b 12299 const struct breakpoint_ops *ops = NULL;
9ac4176b
PA
12300
12301 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12302
12303 if (!arg)
12304 arg = "";
5845583d 12305 sal = ada_decode_assert_location (arg, &addr_string, &cond_string, &ops);
28010a5d 12306 create_ada_exception_catchpoint (gdbarch, sal, addr_string,
5845583d
JB
12307 NULL, cond_string, ops, tempflag,
12308 from_tty);
9ac4176b 12309}
4c4b4cd2
PH
12310 /* Operators */
12311/* Information about operators given special treatment in functions
12312 below. */
12313/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
12314
12315#define ADA_OPERATORS \
12316 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
12317 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
12318 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
12319 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
12320 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
12321 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
12322 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
12323 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
12324 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
12325 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
12326 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
12327 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
12328 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
12329 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
12330 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
12331 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
12332 OP_DEFN (OP_OTHERS, 1, 1, 0) \
12333 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
12334 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
12335
12336static void
554794dc
SDJ
12337ada_operator_length (const struct expression *exp, int pc, int *oplenp,
12338 int *argsp)
4c4b4cd2
PH
12339{
12340 switch (exp->elts[pc - 1].opcode)
12341 {
76a01679 12342 default:
4c4b4cd2
PH
12343 operator_length_standard (exp, pc, oplenp, argsp);
12344 break;
12345
12346#define OP_DEFN(op, len, args, binop) \
12347 case op: *oplenp = len; *argsp = args; break;
12348 ADA_OPERATORS;
12349#undef OP_DEFN
52ce6436
PH
12350
12351 case OP_AGGREGATE:
12352 *oplenp = 3;
12353 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
12354 break;
12355
12356 case OP_CHOICES:
12357 *oplenp = 3;
12358 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
12359 break;
4c4b4cd2
PH
12360 }
12361}
12362
c0201579
JK
12363/* Implementation of the exp_descriptor method operator_check. */
12364
12365static int
12366ada_operator_check (struct expression *exp, int pos,
12367 int (*objfile_func) (struct objfile *objfile, void *data),
12368 void *data)
12369{
12370 const union exp_element *const elts = exp->elts;
12371 struct type *type = NULL;
12372
12373 switch (elts[pos].opcode)
12374 {
12375 case UNOP_IN_RANGE:
12376 case UNOP_QUAL:
12377 type = elts[pos + 1].type;
12378 break;
12379
12380 default:
12381 return operator_check_standard (exp, pos, objfile_func, data);
12382 }
12383
12384 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
12385
12386 if (type && TYPE_OBJFILE (type)
12387 && (*objfile_func) (TYPE_OBJFILE (type), data))
12388 return 1;
12389
12390 return 0;
12391}
12392
4c4b4cd2
PH
12393static char *
12394ada_op_name (enum exp_opcode opcode)
12395{
12396 switch (opcode)
12397 {
76a01679 12398 default:
4c4b4cd2 12399 return op_name_standard (opcode);
52ce6436 12400
4c4b4cd2
PH
12401#define OP_DEFN(op, len, args, binop) case op: return #op;
12402 ADA_OPERATORS;
12403#undef OP_DEFN
52ce6436
PH
12404
12405 case OP_AGGREGATE:
12406 return "OP_AGGREGATE";
12407 case OP_CHOICES:
12408 return "OP_CHOICES";
12409 case OP_NAME:
12410 return "OP_NAME";
4c4b4cd2
PH
12411 }
12412}
12413
12414/* As for operator_length, but assumes PC is pointing at the first
12415 element of the operator, and gives meaningful results only for the
52ce6436 12416 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
12417
12418static void
76a01679
JB
12419ada_forward_operator_length (struct expression *exp, int pc,
12420 int *oplenp, int *argsp)
4c4b4cd2 12421{
76a01679 12422 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
12423 {
12424 default:
12425 *oplenp = *argsp = 0;
12426 break;
52ce6436 12427
4c4b4cd2
PH
12428#define OP_DEFN(op, len, args, binop) \
12429 case op: *oplenp = len; *argsp = args; break;
12430 ADA_OPERATORS;
12431#undef OP_DEFN
52ce6436
PH
12432
12433 case OP_AGGREGATE:
12434 *oplenp = 3;
12435 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
12436 break;
12437
12438 case OP_CHOICES:
12439 *oplenp = 3;
12440 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
12441 break;
12442
12443 case OP_STRING:
12444 case OP_NAME:
12445 {
12446 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 12447
52ce6436
PH
12448 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
12449 *argsp = 0;
12450 break;
12451 }
4c4b4cd2
PH
12452 }
12453}
12454
12455static int
12456ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
12457{
12458 enum exp_opcode op = exp->elts[elt].opcode;
12459 int oplen, nargs;
12460 int pc = elt;
12461 int i;
76a01679 12462
4c4b4cd2
PH
12463 ada_forward_operator_length (exp, elt, &oplen, &nargs);
12464
76a01679 12465 switch (op)
4c4b4cd2 12466 {
76a01679 12467 /* Ada attributes ('Foo). */
4c4b4cd2
PH
12468 case OP_ATR_FIRST:
12469 case OP_ATR_LAST:
12470 case OP_ATR_LENGTH:
12471 case OP_ATR_IMAGE:
12472 case OP_ATR_MAX:
12473 case OP_ATR_MIN:
12474 case OP_ATR_MODULUS:
12475 case OP_ATR_POS:
12476 case OP_ATR_SIZE:
12477 case OP_ATR_TAG:
12478 case OP_ATR_VAL:
12479 break;
12480
12481 case UNOP_IN_RANGE:
12482 case UNOP_QUAL:
323e0a4a
AC
12483 /* XXX: gdb_sprint_host_address, type_sprint */
12484 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
12485 gdb_print_host_address (exp->elts[pc + 1].type, stream);
12486 fprintf_filtered (stream, " (");
12487 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
12488 fprintf_filtered (stream, ")");
12489 break;
12490 case BINOP_IN_BOUNDS:
52ce6436
PH
12491 fprintf_filtered (stream, " (%d)",
12492 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
12493 break;
12494 case TERNOP_IN_RANGE:
12495 break;
12496
52ce6436
PH
12497 case OP_AGGREGATE:
12498 case OP_OTHERS:
12499 case OP_DISCRETE_RANGE:
12500 case OP_POSITIONAL:
12501 case OP_CHOICES:
12502 break;
12503
12504 case OP_NAME:
12505 case OP_STRING:
12506 {
12507 char *name = &exp->elts[elt + 2].string;
12508 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 12509
52ce6436
PH
12510 fprintf_filtered (stream, "Text: `%.*s'", len, name);
12511 break;
12512 }
12513
4c4b4cd2
PH
12514 default:
12515 return dump_subexp_body_standard (exp, stream, elt);
12516 }
12517
12518 elt += oplen;
12519 for (i = 0; i < nargs; i += 1)
12520 elt = dump_subexp (exp, stream, elt);
12521
12522 return elt;
12523}
12524
12525/* The Ada extension of print_subexp (q.v.). */
12526
76a01679
JB
12527static void
12528ada_print_subexp (struct expression *exp, int *pos,
12529 struct ui_file *stream, enum precedence prec)
4c4b4cd2 12530{
52ce6436 12531 int oplen, nargs, i;
4c4b4cd2
PH
12532 int pc = *pos;
12533 enum exp_opcode op = exp->elts[pc].opcode;
12534
12535 ada_forward_operator_length (exp, pc, &oplen, &nargs);
12536
52ce6436 12537 *pos += oplen;
4c4b4cd2
PH
12538 switch (op)
12539 {
12540 default:
52ce6436 12541 *pos -= oplen;
4c4b4cd2
PH
12542 print_subexp_standard (exp, pos, stream, prec);
12543 return;
12544
12545 case OP_VAR_VALUE:
4c4b4cd2
PH
12546 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
12547 return;
12548
12549 case BINOP_IN_BOUNDS:
323e0a4a 12550 /* XXX: sprint_subexp */
4c4b4cd2 12551 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12552 fputs_filtered (" in ", stream);
4c4b4cd2 12553 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12554 fputs_filtered ("'range", stream);
4c4b4cd2 12555 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
12556 fprintf_filtered (stream, "(%ld)",
12557 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
12558 return;
12559
12560 case TERNOP_IN_RANGE:
4c4b4cd2 12561 if (prec >= PREC_EQUAL)
76a01679 12562 fputs_filtered ("(", stream);
323e0a4a 12563 /* XXX: sprint_subexp */
4c4b4cd2 12564 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12565 fputs_filtered (" in ", stream);
4c4b4cd2
PH
12566 print_subexp (exp, pos, stream, PREC_EQUAL);
12567 fputs_filtered (" .. ", stream);
12568 print_subexp (exp, pos, stream, PREC_EQUAL);
12569 if (prec >= PREC_EQUAL)
76a01679
JB
12570 fputs_filtered (")", stream);
12571 return;
4c4b4cd2
PH
12572
12573 case OP_ATR_FIRST:
12574 case OP_ATR_LAST:
12575 case OP_ATR_LENGTH:
12576 case OP_ATR_IMAGE:
12577 case OP_ATR_MAX:
12578 case OP_ATR_MIN:
12579 case OP_ATR_MODULUS:
12580 case OP_ATR_POS:
12581 case OP_ATR_SIZE:
12582 case OP_ATR_TAG:
12583 case OP_ATR_VAL:
4c4b4cd2 12584 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
12585 {
12586 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
12587 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
12588 &type_print_raw_options);
76a01679
JB
12589 *pos += 3;
12590 }
4c4b4cd2 12591 else
76a01679 12592 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
12593 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
12594 if (nargs > 1)
76a01679
JB
12595 {
12596 int tem;
5b4ee69b 12597
76a01679
JB
12598 for (tem = 1; tem < nargs; tem += 1)
12599 {
12600 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
12601 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
12602 }
12603 fputs_filtered (")", stream);
12604 }
4c4b4cd2 12605 return;
14f9c5c9 12606
4c4b4cd2 12607 case UNOP_QUAL:
4c4b4cd2
PH
12608 type_print (exp->elts[pc + 1].type, "", stream, 0);
12609 fputs_filtered ("'(", stream);
12610 print_subexp (exp, pos, stream, PREC_PREFIX);
12611 fputs_filtered (")", stream);
12612 return;
14f9c5c9 12613
4c4b4cd2 12614 case UNOP_IN_RANGE:
323e0a4a 12615 /* XXX: sprint_subexp */
4c4b4cd2 12616 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12617 fputs_filtered (" in ", stream);
79d43c61
TT
12618 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
12619 &type_print_raw_options);
4c4b4cd2 12620 return;
52ce6436
PH
12621
12622 case OP_DISCRETE_RANGE:
12623 print_subexp (exp, pos, stream, PREC_SUFFIX);
12624 fputs_filtered ("..", stream);
12625 print_subexp (exp, pos, stream, PREC_SUFFIX);
12626 return;
12627
12628 case OP_OTHERS:
12629 fputs_filtered ("others => ", stream);
12630 print_subexp (exp, pos, stream, PREC_SUFFIX);
12631 return;
12632
12633 case OP_CHOICES:
12634 for (i = 0; i < nargs-1; i += 1)
12635 {
12636 if (i > 0)
12637 fputs_filtered ("|", stream);
12638 print_subexp (exp, pos, stream, PREC_SUFFIX);
12639 }
12640 fputs_filtered (" => ", stream);
12641 print_subexp (exp, pos, stream, PREC_SUFFIX);
12642 return;
12643
12644 case OP_POSITIONAL:
12645 print_subexp (exp, pos, stream, PREC_SUFFIX);
12646 return;
12647
12648 case OP_AGGREGATE:
12649 fputs_filtered ("(", stream);
12650 for (i = 0; i < nargs; i += 1)
12651 {
12652 if (i > 0)
12653 fputs_filtered (", ", stream);
12654 print_subexp (exp, pos, stream, PREC_SUFFIX);
12655 }
12656 fputs_filtered (")", stream);
12657 return;
4c4b4cd2
PH
12658 }
12659}
14f9c5c9
AS
12660
12661/* Table mapping opcodes into strings for printing operators
12662 and precedences of the operators. */
12663
d2e4a39e
AS
12664static const struct op_print ada_op_print_tab[] = {
12665 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
12666 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
12667 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
12668 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
12669 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
12670 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
12671 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
12672 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
12673 {"<=", BINOP_LEQ, PREC_ORDER, 0},
12674 {">=", BINOP_GEQ, PREC_ORDER, 0},
12675 {">", BINOP_GTR, PREC_ORDER, 0},
12676 {"<", BINOP_LESS, PREC_ORDER, 0},
12677 {">>", BINOP_RSH, PREC_SHIFT, 0},
12678 {"<<", BINOP_LSH, PREC_SHIFT, 0},
12679 {"+", BINOP_ADD, PREC_ADD, 0},
12680 {"-", BINOP_SUB, PREC_ADD, 0},
12681 {"&", BINOP_CONCAT, PREC_ADD, 0},
12682 {"*", BINOP_MUL, PREC_MUL, 0},
12683 {"/", BINOP_DIV, PREC_MUL, 0},
12684 {"rem", BINOP_REM, PREC_MUL, 0},
12685 {"mod", BINOP_MOD, PREC_MUL, 0},
12686 {"**", BINOP_EXP, PREC_REPEAT, 0},
12687 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
12688 {"-", UNOP_NEG, PREC_PREFIX, 0},
12689 {"+", UNOP_PLUS, PREC_PREFIX, 0},
12690 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
12691 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
12692 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
12693 {".all", UNOP_IND, PREC_SUFFIX, 1},
12694 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
12695 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
d2e4a39e 12696 {NULL, 0, 0, 0}
14f9c5c9
AS
12697};
12698\f
72d5681a
PH
12699enum ada_primitive_types {
12700 ada_primitive_type_int,
12701 ada_primitive_type_long,
12702 ada_primitive_type_short,
12703 ada_primitive_type_char,
12704 ada_primitive_type_float,
12705 ada_primitive_type_double,
12706 ada_primitive_type_void,
12707 ada_primitive_type_long_long,
12708 ada_primitive_type_long_double,
12709 ada_primitive_type_natural,
12710 ada_primitive_type_positive,
12711 ada_primitive_type_system_address,
12712 nr_ada_primitive_types
12713};
6c038f32
PH
12714
12715static void
d4a9a881 12716ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
12717 struct language_arch_info *lai)
12718{
d4a9a881 12719 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 12720
72d5681a 12721 lai->primitive_type_vector
d4a9a881 12722 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 12723 struct type *);
e9bb382b
UW
12724
12725 lai->primitive_type_vector [ada_primitive_type_int]
12726 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12727 0, "integer");
12728 lai->primitive_type_vector [ada_primitive_type_long]
12729 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
12730 0, "long_integer");
12731 lai->primitive_type_vector [ada_primitive_type_short]
12732 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
12733 0, "short_integer");
12734 lai->string_char_type
12735 = lai->primitive_type_vector [ada_primitive_type_char]
12736 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
12737 lai->primitive_type_vector [ada_primitive_type_float]
12738 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
12739 "float", NULL);
12740 lai->primitive_type_vector [ada_primitive_type_double]
12741 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
12742 "long_float", NULL);
12743 lai->primitive_type_vector [ada_primitive_type_long_long]
12744 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
12745 0, "long_long_integer");
12746 lai->primitive_type_vector [ada_primitive_type_long_double]
12747 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
12748 "long_long_float", NULL);
12749 lai->primitive_type_vector [ada_primitive_type_natural]
12750 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12751 0, "natural");
12752 lai->primitive_type_vector [ada_primitive_type_positive]
12753 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12754 0, "positive");
12755 lai->primitive_type_vector [ada_primitive_type_void]
12756 = builtin->builtin_void;
12757
12758 lai->primitive_type_vector [ada_primitive_type_system_address]
12759 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
72d5681a
PH
12760 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
12761 = "system__address";
fbb06eb1 12762
47e729a8 12763 lai->bool_type_symbol = NULL;
fbb06eb1 12764 lai->bool_type_default = builtin->builtin_bool;
6c038f32 12765}
6c038f32
PH
12766\f
12767 /* Language vector */
12768
12769/* Not really used, but needed in the ada_language_defn. */
12770
12771static void
6c7a06a3 12772emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 12773{
6c7a06a3 12774 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
12775}
12776
12777static int
12778parse (void)
12779{
12780 warnings_issued = 0;
12781 return ada_parse ();
12782}
12783
12784static const struct exp_descriptor ada_exp_descriptor = {
12785 ada_print_subexp,
12786 ada_operator_length,
c0201579 12787 ada_operator_check,
6c038f32
PH
12788 ada_op_name,
12789 ada_dump_subexp_body,
12790 ada_evaluate_subexp
12791};
12792
1a119f36 12793/* Implement the "la_get_symbol_name_cmp" language_defn method
74ccd7f5
JB
12794 for Ada. */
12795
1a119f36
JB
12796static symbol_name_cmp_ftype
12797ada_get_symbol_name_cmp (const char *lookup_name)
74ccd7f5
JB
12798{
12799 if (should_use_wild_match (lookup_name))
12800 return wild_match;
12801 else
12802 return compare_names;
12803}
12804
a5ee536b
JB
12805/* Implement the "la_read_var_value" language_defn method for Ada. */
12806
12807static struct value *
12808ada_read_var_value (struct symbol *var, struct frame_info *frame)
12809{
12810 struct block *frame_block = NULL;
12811 struct symbol *renaming_sym = NULL;
12812
12813 /* The only case where default_read_var_value is not sufficient
12814 is when VAR is a renaming... */
12815 if (frame)
12816 frame_block = get_frame_block (frame, NULL);
12817 if (frame_block)
12818 renaming_sym = ada_find_renaming_symbol (var, frame_block);
12819 if (renaming_sym != NULL)
12820 return ada_read_renaming_var_value (renaming_sym, frame_block);
12821
12822 /* This is a typical case where we expect the default_read_var_value
12823 function to work. */
12824 return default_read_var_value (var, frame);
12825}
12826
6c038f32
PH
12827const struct language_defn ada_language_defn = {
12828 "ada", /* Language name */
12829 language_ada,
6c038f32 12830 range_check_off,
6c038f32
PH
12831 case_sensitive_on, /* Yes, Ada is case-insensitive, but
12832 that's not quite what this means. */
6c038f32 12833 array_row_major,
9a044a89 12834 macro_expansion_no,
6c038f32
PH
12835 &ada_exp_descriptor,
12836 parse,
12837 ada_error,
12838 resolve,
12839 ada_printchar, /* Print a character constant */
12840 ada_printstr, /* Function to print string constant */
12841 emit_char, /* Function to print single char (not used) */
6c038f32 12842 ada_print_type, /* Print a type using appropriate syntax */
be942545 12843 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
12844 ada_val_print, /* Print a value using appropriate syntax */
12845 ada_value_print, /* Print a top-level value */
a5ee536b 12846 ada_read_var_value, /* la_read_var_value */
6c038f32 12847 NULL, /* Language specific skip_trampoline */
2b2d9e11 12848 NULL, /* name_of_this */
6c038f32
PH
12849 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
12850 basic_lookup_transparent_type, /* lookup_transparent_type */
12851 ada_la_decode, /* Language specific symbol demangler */
0963b4bd
MS
12852 NULL, /* Language specific
12853 class_name_from_physname */
6c038f32
PH
12854 ada_op_print_tab, /* expression operators for printing */
12855 0, /* c-style arrays */
12856 1, /* String lower bound */
6c038f32 12857 ada_get_gdb_completer_word_break_characters,
41d27058 12858 ada_make_symbol_completion_list,
72d5681a 12859 ada_language_arch_info,
e79af960 12860 ada_print_array_index,
41f1b697 12861 default_pass_by_reference,
ae6a3a4c 12862 c_get_string,
1a119f36 12863 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
f8eba3c6 12864 ada_iterate_over_symbols,
6c038f32
PH
12865 LANG_MAGIC
12866};
12867
2c0b251b
PA
12868/* Provide a prototype to silence -Wmissing-prototypes. */
12869extern initialize_file_ftype _initialize_ada_language;
12870
5bf03f13
JB
12871/* Command-list for the "set/show ada" prefix command. */
12872static struct cmd_list_element *set_ada_list;
12873static struct cmd_list_element *show_ada_list;
12874
12875/* Implement the "set ada" prefix command. */
12876
12877static void
12878set_ada_command (char *arg, int from_tty)
12879{
12880 printf_unfiltered (_(\
12881"\"set ada\" must be followed by the name of a setting.\n"));
12882 help_list (set_ada_list, "set ada ", -1, gdb_stdout);
12883}
12884
12885/* Implement the "show ada" prefix command. */
12886
12887static void
12888show_ada_command (char *args, int from_tty)
12889{
12890 cmd_show_list (show_ada_list, from_tty, "");
12891}
12892
2060206e
PA
12893static void
12894initialize_ada_catchpoint_ops (void)
12895{
12896 struct breakpoint_ops *ops;
12897
12898 initialize_breakpoint_ops ();
12899
12900 ops = &catch_exception_breakpoint_ops;
12901 *ops = bkpt_breakpoint_ops;
12902 ops->dtor = dtor_catch_exception;
12903 ops->allocate_location = allocate_location_catch_exception;
12904 ops->re_set = re_set_catch_exception;
12905 ops->check_status = check_status_catch_exception;
12906 ops->print_it = print_it_catch_exception;
12907 ops->print_one = print_one_catch_exception;
12908 ops->print_mention = print_mention_catch_exception;
12909 ops->print_recreate = print_recreate_catch_exception;
12910
12911 ops = &catch_exception_unhandled_breakpoint_ops;
12912 *ops = bkpt_breakpoint_ops;
12913 ops->dtor = dtor_catch_exception_unhandled;
12914 ops->allocate_location = allocate_location_catch_exception_unhandled;
12915 ops->re_set = re_set_catch_exception_unhandled;
12916 ops->check_status = check_status_catch_exception_unhandled;
12917 ops->print_it = print_it_catch_exception_unhandled;
12918 ops->print_one = print_one_catch_exception_unhandled;
12919 ops->print_mention = print_mention_catch_exception_unhandled;
12920 ops->print_recreate = print_recreate_catch_exception_unhandled;
12921
12922 ops = &catch_assert_breakpoint_ops;
12923 *ops = bkpt_breakpoint_ops;
12924 ops->dtor = dtor_catch_assert;
12925 ops->allocate_location = allocate_location_catch_assert;
12926 ops->re_set = re_set_catch_assert;
12927 ops->check_status = check_status_catch_assert;
12928 ops->print_it = print_it_catch_assert;
12929 ops->print_one = print_one_catch_assert;
12930 ops->print_mention = print_mention_catch_assert;
12931 ops->print_recreate = print_recreate_catch_assert;
12932}
12933
d2e4a39e 12934void
6c038f32 12935_initialize_ada_language (void)
14f9c5c9 12936{
6c038f32
PH
12937 add_language (&ada_language_defn);
12938
2060206e
PA
12939 initialize_ada_catchpoint_ops ();
12940
5bf03f13
JB
12941 add_prefix_cmd ("ada", no_class, set_ada_command,
12942 _("Prefix command for changing Ada-specfic settings"),
12943 &set_ada_list, "set ada ", 0, &setlist);
12944
12945 add_prefix_cmd ("ada", no_class, show_ada_command,
12946 _("Generic command for showing Ada-specific settings."),
12947 &show_ada_list, "show ada ", 0, &showlist);
12948
12949 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
12950 &trust_pad_over_xvs, _("\
12951Enable or disable an optimization trusting PAD types over XVS types"), _("\
12952Show whether an optimization trusting PAD types over XVS types is activated"),
12953 _("\
12954This is related to the encoding used by the GNAT compiler. The debugger\n\
12955should normally trust the contents of PAD types, but certain older versions\n\
12956of GNAT have a bug that sometimes causes the information in the PAD type\n\
12957to be incorrect. Turning this setting \"off\" allows the debugger to\n\
12958work around this bug. It is always safe to turn this option \"off\", but\n\
12959this incurs a slight performance penalty, so it is recommended to NOT change\n\
12960this option to \"off\" unless necessary."),
12961 NULL, NULL, &set_ada_list, &show_ada_list);
12962
9ac4176b
PA
12963 add_catch_command ("exception", _("\
12964Catch Ada exceptions, when raised.\n\
12965With an argument, catch only exceptions with the given name."),
12966 catch_ada_exception_command,
12967 NULL,
12968 CATCH_PERMANENT,
12969 CATCH_TEMPORARY);
12970 add_catch_command ("assert", _("\
12971Catch failed Ada assertions, when raised.\n\
12972With an argument, catch only exceptions with the given name."),
12973 catch_assert_command,
12974 NULL,
12975 CATCH_PERMANENT,
12976 CATCH_TEMPORARY);
12977
6c038f32 12978 varsize_limit = 65536;
6c038f32
PH
12979
12980 obstack_init (&symbol_list_obstack);
12981
12982 decoded_names_store = htab_create_alloc
12983 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
12984 NULL, xcalloc, xfree);
6b69afc4 12985
e802dbe0
JB
12986 /* Setup per-inferior data. */
12987 observer_attach_inferior_exit (ada_inferior_exit);
12988 ada_inferior_data
8e260fc0 12989 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
14f9c5c9 12990}