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