]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
Constify 'la_name' in struct language_defn
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
6e681866 1/* Ada language support routines for GDB, the GNU debugger.
10a2c479 2
28e7fd62 3 Copyright (C) 1992-2013 Free Software Foundation, Inc.
14f9c5c9 4
a9762ec7 5 This file is part of GDB.
14f9c5c9 6
a9762ec7
JB
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
14f9c5c9 11
a9762ec7
JB
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
14f9c5c9 16
a9762ec7
JB
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
14f9c5c9 19
96d887e8 20
4c4b4cd2 21#include "defs.h"
14f9c5c9 22#include <stdio.h>
0c30c098 23#include "gdb_string.h"
14f9c5c9
AS
24#include <ctype.h>
25#include <stdarg.h>
26#include "demangle.h"
4c4b4cd2
PH
27#include "gdb_regex.h"
28#include "frame.h"
14f9c5c9
AS
29#include "symtab.h"
30#include "gdbtypes.h"
31#include "gdbcmd.h"
32#include "expression.h"
33#include "parser-defs.h"
34#include "language.h"
a53b64ea 35#include "varobj.h"
14f9c5c9
AS
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"
79d43c61 61#include "typeprint.h"
14f9c5c9 62
ccefe4c4 63#include "psymtab.h"
40bc484c 64#include "value.h"
956a9fb9 65#include "mi/mi-common.h"
9ac4176b 66#include "arch-utils.h"
28010a5d 67#include "exceptions.h"
0fcd72ba 68#include "cli/cli-utils.h"
ccefe4c4 69
4c4b4cd2 70/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 71 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
72 Copied from valarith.c. */
73
74#ifndef TRUNCATION_TOWARDS_ZERO
75#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
76#endif
77
d2e4a39e 78static struct type *desc_base_type (struct type *);
14f9c5c9 79
d2e4a39e 80static struct type *desc_bounds_type (struct type *);
14f9c5c9 81
d2e4a39e 82static struct value *desc_bounds (struct value *);
14f9c5c9 83
d2e4a39e 84static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 85
d2e4a39e 86static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 87
556bdfd4 88static struct type *desc_data_target_type (struct type *);
14f9c5c9 89
d2e4a39e 90static struct value *desc_data (struct value *);
14f9c5c9 91
d2e4a39e 92static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 93
d2e4a39e 94static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 95
d2e4a39e 96static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 97
d2e4a39e 98static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 99
d2e4a39e 100static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 101
d2e4a39e 102static struct type *desc_index_type (struct type *, int);
14f9c5c9 103
d2e4a39e 104static int desc_arity (struct type *);
14f9c5c9 105
d2e4a39e 106static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 107
d2e4a39e 108static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 109
40658b94
PH
110static int full_match (const char *, const char *);
111
40bc484c 112static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 113
4c4b4cd2 114static void ada_add_block_symbols (struct obstack *,
76a01679 115 struct block *, const char *,
2570f2b7 116 domain_enum, struct objfile *, int);
14f9c5c9 117
4c4b4cd2 118static int is_nonfunction (struct ada_symbol_info *, int);
14f9c5c9 119
76a01679 120static void add_defn_to_vec (struct obstack *, struct symbol *,
2570f2b7 121 struct block *);
14f9c5c9 122
4c4b4cd2
PH
123static int num_defns_collected (struct obstack *);
124
125static struct ada_symbol_info *defns_collected (struct obstack *, int);
14f9c5c9 126
4c4b4cd2 127static struct value *resolve_subexp (struct expression **, int *, int,
76a01679 128 struct type *);
14f9c5c9 129
d2e4a39e 130static void replace_operator_with_call (struct expression **, int, int, int,
270140bd 131 struct symbol *, const struct block *);
14f9c5c9 132
d2e4a39e 133static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 134
4c4b4cd2
PH
135static char *ada_op_name (enum exp_opcode);
136
137static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 138
d2e4a39e 139static int numeric_type_p (struct type *);
14f9c5c9 140
d2e4a39e 141static int integer_type_p (struct type *);
14f9c5c9 142
d2e4a39e 143static int scalar_type_p (struct type *);
14f9c5c9 144
d2e4a39e 145static int discrete_type_p (struct type *);
14f9c5c9 146
aeb5907d
JB
147static enum ada_renaming_category parse_old_style_renaming (struct type *,
148 const char **,
149 int *,
150 const char **);
151
152static struct symbol *find_old_style_renaming_symbol (const char *,
270140bd 153 const struct block *);
aeb5907d 154
4c4b4cd2 155static struct type *ada_lookup_struct_elt_type (struct type *, char *,
76a01679 156 int, int, int *);
4c4b4cd2 157
d2e4a39e 158static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 159
b4ba55a1
JB
160static struct type *ada_find_parallel_type_with_name (struct type *,
161 const char *);
162
d2e4a39e 163static int is_dynamic_field (struct type *, int);
14f9c5c9 164
10a2c479 165static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 166 const gdb_byte *,
4c4b4cd2
PH
167 CORE_ADDR, struct value *);
168
169static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 170
28c85d6c 171static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 172
d2e4a39e 173static struct type *to_static_fixed_type (struct type *);
f192137b 174static struct type *static_unwrap_type (struct type *type);
14f9c5c9 175
d2e4a39e 176static struct value *unwrap_value (struct value *);
14f9c5c9 177
ad82864c 178static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 179
ad82864c 180static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 181
ad82864c
JB
182static long decode_packed_array_bitsize (struct type *);
183
184static struct value *decode_constrained_packed_array (struct value *);
185
186static int ada_is_packed_array_type (struct type *);
187
188static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 189
d2e4a39e 190static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 191 struct value **);
14f9c5c9 192
50810684 193static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
52ce6436 194
4c4b4cd2
PH
195static struct value *coerce_unspec_val_to_type (struct value *,
196 struct type *);
14f9c5c9 197
d2e4a39e 198static struct value *get_var_value (char *, char *);
14f9c5c9 199
d2e4a39e 200static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 201
d2e4a39e 202static int equiv_types (struct type *, struct type *);
14f9c5c9 203
d2e4a39e 204static int is_name_suffix (const char *);
14f9c5c9 205
73589123
PH
206static int advance_wild_match (const char **, const char *, int);
207
208static int wild_match (const char *, const char *);
14f9c5c9 209
d2e4a39e 210static struct value *ada_coerce_ref (struct value *);
14f9c5c9 211
4c4b4cd2
PH
212static LONGEST pos_atr (struct value *);
213
3cb382c9 214static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 215
d2e4a39e 216static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 217
4c4b4cd2
PH
218static struct symbol *standard_lookup (const char *, const struct block *,
219 domain_enum);
14f9c5c9 220
4c4b4cd2
PH
221static struct value *ada_search_struct_field (char *, struct value *, int,
222 struct type *);
223
224static struct value *ada_value_primitive_field (struct value *, int, int,
225 struct type *);
226
0d5cff50 227static int find_struct_field (const char *, struct type *, int,
52ce6436 228 struct type **, int *, int *, int *, int *);
4c4b4cd2
PH
229
230static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
231 struct value *);
232
4c4b4cd2
PH
233static int ada_resolve_function (struct ada_symbol_info *, int,
234 struct value **, int, const char *,
235 struct type *);
236
4c4b4cd2
PH
237static int ada_is_direct_array_type (struct type *);
238
72d5681a
PH
239static void ada_language_arch_info (struct gdbarch *,
240 struct language_arch_info *);
714e53ab
PH
241
242static void check_size (const struct type *);
52ce6436
PH
243
244static struct value *ada_index_struct_field (int, struct value *, int,
245 struct type *);
246
247static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
248 struct expression *,
249 int *, enum noside);
52ce6436
PH
250
251static void aggregate_assign_from_choices (struct value *, struct value *,
252 struct expression *,
253 int *, LONGEST *, int *,
254 int, LONGEST, LONGEST);
255
256static void aggregate_assign_positional (struct value *, struct value *,
257 struct expression *,
258 int *, LONGEST *, int *, int,
259 LONGEST, LONGEST);
260
261
262static void aggregate_assign_others (struct value *, struct value *,
263 struct expression *,
264 int *, LONGEST *, int, LONGEST, LONGEST);
265
266
267static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
268
269
270static struct value *ada_evaluate_subexp (struct type *, struct expression *,
271 int *, enum noside);
272
273static void ada_forward_operator_length (struct expression *, int, int *,
274 int *);
852dff6c
JB
275
276static struct type *ada_find_any_type (const char *name);
4c4b4cd2
PH
277\f
278
76a01679 279
4c4b4cd2 280/* Maximum-sized dynamic type. */
14f9c5c9
AS
281static unsigned int varsize_limit;
282
4c4b4cd2
PH
283/* FIXME: brobecker/2003-09-17: No longer a const because it is
284 returned by a function that does not return a const char *. */
285static char *ada_completer_word_break_characters =
286#ifdef VMS
287 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
288#else
14f9c5c9 289 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 290#endif
14f9c5c9 291
4c4b4cd2 292/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 293static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 294 = "__gnat_ada_main_program_name";
14f9c5c9 295
4c4b4cd2
PH
296/* Limit on the number of warnings to raise per expression evaluation. */
297static int warning_limit = 2;
298
299/* Number of warning messages issued; reset to 0 by cleanups after
300 expression evaluation. */
301static int warnings_issued = 0;
302
303static const char *known_runtime_file_name_patterns[] = {
304 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
305};
306
307static const char *known_auxiliary_function_name_patterns[] = {
308 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
309};
310
311/* Space for allocating results of ada_lookup_symbol_list. */
312static struct obstack symbol_list_obstack;
313
e802dbe0
JB
314 /* Inferior-specific data. */
315
316/* Per-inferior data for this module. */
317
318struct ada_inferior_data
319{
320 /* The ada__tags__type_specific_data type, which is used when decoding
321 tagged types. With older versions of GNAT, this type was directly
322 accessible through a component ("tsd") in the object tag. But this
323 is no longer the case, so we cache it for each inferior. */
324 struct type *tsd_type;
3eecfa55
JB
325
326 /* The exception_support_info data. This data is used to determine
327 how to implement support for Ada exception catchpoints in a given
328 inferior. */
329 const struct exception_support_info *exception_info;
e802dbe0
JB
330};
331
332/* Our key to this module's inferior data. */
333static const struct inferior_data *ada_inferior_data;
334
335/* A cleanup routine for our inferior data. */
336static void
337ada_inferior_data_cleanup (struct inferior *inf, void *arg)
338{
339 struct ada_inferior_data *data;
340
341 data = inferior_data (inf, ada_inferior_data);
342 if (data != NULL)
343 xfree (data);
344}
345
346/* Return our inferior data for the given inferior (INF).
347
348 This function always returns a valid pointer to an allocated
349 ada_inferior_data structure. If INF's inferior data has not
350 been previously set, this functions creates a new one with all
351 fields set to zero, sets INF's inferior to it, and then returns
352 a pointer to that newly allocated ada_inferior_data. */
353
354static struct ada_inferior_data *
355get_ada_inferior_data (struct inferior *inf)
356{
357 struct ada_inferior_data *data;
358
359 data = inferior_data (inf, ada_inferior_data);
360 if (data == NULL)
361 {
362 data = XZALLOC (struct ada_inferior_data);
363 set_inferior_data (inf, ada_inferior_data, data);
364 }
365
366 return data;
367}
368
369/* Perform all necessary cleanups regarding our module's inferior data
370 that is required after the inferior INF just exited. */
371
372static void
373ada_inferior_exit (struct inferior *inf)
374{
375 ada_inferior_data_cleanup (inf, NULL);
376 set_inferior_data (inf, ada_inferior_data, NULL);
377}
378
4c4b4cd2
PH
379 /* Utilities */
380
720d1a40 381/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
eed9788b 382 all typedef layers have been peeled. Otherwise, return TYPE.
720d1a40
JB
383
384 Normally, we really expect a typedef type to only have 1 typedef layer.
385 In other words, we really expect the target type of a typedef type to be
386 a non-typedef type. This is particularly true for Ada units, because
387 the language does not have a typedef vs not-typedef distinction.
388 In that respect, the Ada compiler has been trying to eliminate as many
389 typedef definitions in the debugging information, since they generally
390 do not bring any extra information (we still use typedef under certain
391 circumstances related mostly to the GNAT encoding).
392
393 Unfortunately, we have seen situations where the debugging information
394 generated by the compiler leads to such multiple typedef layers. For
395 instance, consider the following example with stabs:
396
397 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
398 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
399
400 This is an error in the debugging information which causes type
401 pck__float_array___XUP to be defined twice, and the second time,
402 it is defined as a typedef of a typedef.
403
404 This is on the fringe of legality as far as debugging information is
405 concerned, and certainly unexpected. But it is easy to handle these
406 situations correctly, so we can afford to be lenient in this case. */
407
408static struct type *
409ada_typedef_target_type (struct type *type)
410{
411 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
412 type = TYPE_TARGET_TYPE (type);
413 return type;
414}
415
41d27058
JB
416/* Given DECODED_NAME a string holding a symbol name in its
417 decoded form (ie using the Ada dotted notation), returns
418 its unqualified name. */
419
420static const char *
421ada_unqualified_name (const char *decoded_name)
422{
423 const char *result = strrchr (decoded_name, '.');
424
425 if (result != NULL)
426 result++; /* Skip the dot... */
427 else
428 result = decoded_name;
429
430 return result;
431}
432
433/* Return a string starting with '<', followed by STR, and '>'.
434 The result is good until the next call. */
435
436static char *
437add_angle_brackets (const char *str)
438{
439 static char *result = NULL;
440
441 xfree (result);
88c15c34 442 result = xstrprintf ("<%s>", str);
41d27058
JB
443 return result;
444}
96d887e8 445
4c4b4cd2
PH
446static char *
447ada_get_gdb_completer_word_break_characters (void)
448{
449 return ada_completer_word_break_characters;
450}
451
e79af960
JB
452/* Print an array element index using the Ada syntax. */
453
454static void
455ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 456 const struct value_print_options *options)
e79af960 457{
79a45b7d 458 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
459 fprintf_filtered (stream, " => ");
460}
461
f27cf670 462/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 463 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 464 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 465
f27cf670
AS
466void *
467grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 468{
d2e4a39e
AS
469 if (*size < min_size)
470 {
471 *size *= 2;
472 if (*size < min_size)
4c4b4cd2 473 *size = min_size;
f27cf670 474 vect = xrealloc (vect, *size * element_size);
d2e4a39e 475 }
f27cf670 476 return vect;
14f9c5c9
AS
477}
478
479/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 480 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
481
482static int
ebf56fd3 483field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
484{
485 int len = strlen (target);
5b4ee69b 486
d2e4a39e 487 return
4c4b4cd2
PH
488 (strncmp (field_name, target, len) == 0
489 && (field_name[len] == '\0'
490 || (strncmp (field_name + len, "___", 3) == 0
76a01679
JB
491 && strcmp (field_name + strlen (field_name) - 6,
492 "___XVN") != 0)));
14f9c5c9
AS
493}
494
495
872c8b51
JB
496/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
497 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
498 and return its index. This function also handles fields whose name
499 have ___ suffixes because the compiler sometimes alters their name
500 by adding such a suffix to represent fields with certain constraints.
501 If the field could not be found, return a negative number if
502 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
503
504int
505ada_get_field_index (const struct type *type, const char *field_name,
506 int maybe_missing)
507{
508 int fieldno;
872c8b51
JB
509 struct type *struct_type = check_typedef ((struct type *) type);
510
511 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
512 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
513 return fieldno;
514
515 if (!maybe_missing)
323e0a4a 516 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 517 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
518
519 return -1;
520}
521
522/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
523
524int
d2e4a39e 525ada_name_prefix_len (const char *name)
14f9c5c9
AS
526{
527 if (name == NULL)
528 return 0;
d2e4a39e 529 else
14f9c5c9 530 {
d2e4a39e 531 const char *p = strstr (name, "___");
5b4ee69b 532
14f9c5c9 533 if (p == NULL)
4c4b4cd2 534 return strlen (name);
14f9c5c9 535 else
4c4b4cd2 536 return p - name;
14f9c5c9
AS
537 }
538}
539
4c4b4cd2
PH
540/* Return non-zero if SUFFIX is a suffix of STR.
541 Return zero if STR is null. */
542
14f9c5c9 543static int
d2e4a39e 544is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
545{
546 int len1, len2;
5b4ee69b 547
14f9c5c9
AS
548 if (str == NULL)
549 return 0;
550 len1 = strlen (str);
551 len2 = strlen (suffix);
4c4b4cd2 552 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
553}
554
4c4b4cd2
PH
555/* The contents of value VAL, treated as a value of type TYPE. The
556 result is an lval in memory if VAL is. */
14f9c5c9 557
d2e4a39e 558static struct value *
4c4b4cd2 559coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 560{
61ee279c 561 type = ada_check_typedef (type);
df407dfe 562 if (value_type (val) == type)
4c4b4cd2 563 return val;
d2e4a39e 564 else
14f9c5c9 565 {
4c4b4cd2
PH
566 struct value *result;
567
568 /* Make sure that the object size is not unreasonable before
569 trying to allocate some memory for it. */
714e53ab 570 check_size (type);
4c4b4cd2 571
41e8491f
JK
572 if (value_lazy (val)
573 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
574 result = allocate_value_lazy (type);
575 else
576 {
577 result = allocate_value (type);
578 memcpy (value_contents_raw (result), value_contents (val),
579 TYPE_LENGTH (type));
580 }
74bcbdf3 581 set_value_component_location (result, val);
9bbda503
AC
582 set_value_bitsize (result, value_bitsize (val));
583 set_value_bitpos (result, value_bitpos (val));
42ae5230 584 set_value_address (result, value_address (val));
eca07816 585 set_value_optimized_out (result, value_optimized_out_const (val));
14f9c5c9
AS
586 return result;
587 }
588}
589
fc1a4b47
AC
590static const gdb_byte *
591cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
592{
593 if (valaddr == NULL)
594 return NULL;
595 else
596 return valaddr + offset;
597}
598
599static CORE_ADDR
ebf56fd3 600cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
601{
602 if (address == 0)
603 return 0;
d2e4a39e 604 else
14f9c5c9
AS
605 return address + offset;
606}
607
4c4b4cd2
PH
608/* Issue a warning (as for the definition of warning in utils.c, but
609 with exactly one argument rather than ...), unless the limit on the
610 number of warnings has passed during the evaluation of the current
611 expression. */
a2249542 612
77109804
AC
613/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
614 provided by "complaint". */
a0b31db1 615static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 616
14f9c5c9 617static void
a2249542 618lim_warning (const char *format, ...)
14f9c5c9 619{
a2249542 620 va_list args;
a2249542 621
5b4ee69b 622 va_start (args, format);
4c4b4cd2
PH
623 warnings_issued += 1;
624 if (warnings_issued <= warning_limit)
a2249542
MK
625 vwarning (format, args);
626
627 va_end (args);
4c4b4cd2
PH
628}
629
714e53ab
PH
630/* Issue an error if the size of an object of type T is unreasonable,
631 i.e. if it would be a bad idea to allocate a value of this type in
632 GDB. */
633
634static void
635check_size (const struct type *type)
636{
637 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 638 error (_("object size is larger than varsize-limit"));
714e53ab
PH
639}
640
0963b4bd 641/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 642static LONGEST
c3e5cd34 643max_of_size (int size)
4c4b4cd2 644{
76a01679 645 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 646
76a01679 647 return top_bit | (top_bit - 1);
4c4b4cd2
PH
648}
649
0963b4bd 650/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 651static LONGEST
c3e5cd34 652min_of_size (int size)
4c4b4cd2 653{
c3e5cd34 654 return -max_of_size (size) - 1;
4c4b4cd2
PH
655}
656
0963b4bd 657/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 658static ULONGEST
c3e5cd34 659umax_of_size (int size)
4c4b4cd2 660{
76a01679 661 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 662
76a01679 663 return top_bit | (top_bit - 1);
4c4b4cd2
PH
664}
665
0963b4bd 666/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
667static LONGEST
668max_of_type (struct type *t)
4c4b4cd2 669{
c3e5cd34
PH
670 if (TYPE_UNSIGNED (t))
671 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
672 else
673 return max_of_size (TYPE_LENGTH (t));
674}
675
0963b4bd 676/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
677static LONGEST
678min_of_type (struct type *t)
679{
680 if (TYPE_UNSIGNED (t))
681 return 0;
682 else
683 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
684}
685
686/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
687LONGEST
688ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 689{
76a01679 690 switch (TYPE_CODE (type))
4c4b4cd2
PH
691 {
692 case TYPE_CODE_RANGE:
690cc4eb 693 return TYPE_HIGH_BOUND (type);
4c4b4cd2 694 case TYPE_CODE_ENUM:
14e75d8e 695 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
696 case TYPE_CODE_BOOL:
697 return 1;
698 case TYPE_CODE_CHAR:
76a01679 699 case TYPE_CODE_INT:
690cc4eb 700 return max_of_type (type);
4c4b4cd2 701 default:
43bbcdc2 702 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
703 }
704}
705
14e75d8e 706/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
707LONGEST
708ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 709{
76a01679 710 switch (TYPE_CODE (type))
4c4b4cd2
PH
711 {
712 case TYPE_CODE_RANGE:
690cc4eb 713 return TYPE_LOW_BOUND (type);
4c4b4cd2 714 case TYPE_CODE_ENUM:
14e75d8e 715 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
716 case TYPE_CODE_BOOL:
717 return 0;
718 case TYPE_CODE_CHAR:
76a01679 719 case TYPE_CODE_INT:
690cc4eb 720 return min_of_type (type);
4c4b4cd2 721 default:
43bbcdc2 722 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
723 }
724}
725
726/* The identity on non-range types. For range types, the underlying
76a01679 727 non-range scalar type. */
4c4b4cd2
PH
728
729static struct type *
18af8284 730get_base_type (struct type *type)
4c4b4cd2
PH
731{
732 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
733 {
76a01679
JB
734 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
735 return type;
4c4b4cd2
PH
736 type = TYPE_TARGET_TYPE (type);
737 }
738 return type;
14f9c5c9 739}
41246937
JB
740
741/* Return a decoded version of the given VALUE. This means returning
742 a value whose type is obtained by applying all the GNAT-specific
743 encondings, making the resulting type a static but standard description
744 of the initial type. */
745
746struct value *
747ada_get_decoded_value (struct value *value)
748{
749 struct type *type = ada_check_typedef (value_type (value));
750
751 if (ada_is_array_descriptor_type (type)
752 || (ada_is_constrained_packed_array_type (type)
753 && TYPE_CODE (type) != TYPE_CODE_PTR))
754 {
755 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
756 value = ada_coerce_to_simple_array_ptr (value);
757 else
758 value = ada_coerce_to_simple_array (value);
759 }
760 else
761 value = ada_to_fixed_value (value);
762
763 return value;
764}
765
766/* Same as ada_get_decoded_value, but with the given TYPE.
767 Because there is no associated actual value for this type,
768 the resulting type might be a best-effort approximation in
769 the case of dynamic types. */
770
771struct type *
772ada_get_decoded_type (struct type *type)
773{
774 type = to_static_fixed_type (type);
775 if (ada_is_constrained_packed_array_type (type))
776 type = ada_coerce_to_simple_array_type (type);
777 return type;
778}
779
4c4b4cd2 780\f
76a01679 781
4c4b4cd2 782 /* Language Selection */
14f9c5c9
AS
783
784/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 785 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 786
14f9c5c9 787enum language
ccefe4c4 788ada_update_initial_language (enum language lang)
14f9c5c9 789{
d2e4a39e 790 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
4c4b4cd2
PH
791 (struct objfile *) NULL) != NULL)
792 return language_ada;
14f9c5c9
AS
793
794 return lang;
795}
96d887e8
PH
796
797/* If the main procedure is written in Ada, then return its name.
798 The result is good until the next call. Return NULL if the main
799 procedure doesn't appear to be in Ada. */
800
801char *
802ada_main_name (void)
803{
804 struct minimal_symbol *msym;
f9bc20b9 805 static char *main_program_name = NULL;
6c038f32 806
96d887e8
PH
807 /* For Ada, the name of the main procedure is stored in a specific
808 string constant, generated by the binder. Look for that symbol,
809 extract its address, and then read that string. If we didn't find
810 that string, then most probably the main procedure is not written
811 in Ada. */
812 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
813
814 if (msym != NULL)
815 {
f9bc20b9
JB
816 CORE_ADDR main_program_name_addr;
817 int err_code;
818
96d887e8
PH
819 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
820 if (main_program_name_addr == 0)
323e0a4a 821 error (_("Invalid address for Ada main program name."));
96d887e8 822
f9bc20b9
JB
823 xfree (main_program_name);
824 target_read_string (main_program_name_addr, &main_program_name,
825 1024, &err_code);
826
827 if (err_code != 0)
828 return NULL;
96d887e8
PH
829 return main_program_name;
830 }
831
832 /* The main procedure doesn't seem to be in Ada. */
833 return NULL;
834}
14f9c5c9 835\f
4c4b4cd2 836 /* Symbols */
d2e4a39e 837
4c4b4cd2
PH
838/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
839 of NULLs. */
14f9c5c9 840
d2e4a39e
AS
841const struct ada_opname_map ada_opname_table[] = {
842 {"Oadd", "\"+\"", BINOP_ADD},
843 {"Osubtract", "\"-\"", BINOP_SUB},
844 {"Omultiply", "\"*\"", BINOP_MUL},
845 {"Odivide", "\"/\"", BINOP_DIV},
846 {"Omod", "\"mod\"", BINOP_MOD},
847 {"Orem", "\"rem\"", BINOP_REM},
848 {"Oexpon", "\"**\"", BINOP_EXP},
849 {"Olt", "\"<\"", BINOP_LESS},
850 {"Ole", "\"<=\"", BINOP_LEQ},
851 {"Ogt", "\">\"", BINOP_GTR},
852 {"Oge", "\">=\"", BINOP_GEQ},
853 {"Oeq", "\"=\"", BINOP_EQUAL},
854 {"One", "\"/=\"", BINOP_NOTEQUAL},
855 {"Oand", "\"and\"", BINOP_BITWISE_AND},
856 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
857 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
858 {"Oconcat", "\"&\"", BINOP_CONCAT},
859 {"Oabs", "\"abs\"", UNOP_ABS},
860 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
861 {"Oadd", "\"+\"", UNOP_PLUS},
862 {"Osubtract", "\"-\"", UNOP_NEG},
863 {NULL, NULL}
14f9c5c9
AS
864};
865
4c4b4cd2
PH
866/* The "encoded" form of DECODED, according to GNAT conventions.
867 The result is valid until the next call to ada_encode. */
868
14f9c5c9 869char *
4c4b4cd2 870ada_encode (const char *decoded)
14f9c5c9 871{
4c4b4cd2
PH
872 static char *encoding_buffer = NULL;
873 static size_t encoding_buffer_size = 0;
d2e4a39e 874 const char *p;
14f9c5c9 875 int k;
d2e4a39e 876
4c4b4cd2 877 if (decoded == NULL)
14f9c5c9
AS
878 return NULL;
879
4c4b4cd2
PH
880 GROW_VECT (encoding_buffer, encoding_buffer_size,
881 2 * strlen (decoded) + 10);
14f9c5c9
AS
882
883 k = 0;
4c4b4cd2 884 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 885 {
cdc7bb92 886 if (*p == '.')
4c4b4cd2
PH
887 {
888 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
889 k += 2;
890 }
14f9c5c9 891 else if (*p == '"')
4c4b4cd2
PH
892 {
893 const struct ada_opname_map *mapping;
894
895 for (mapping = ada_opname_table;
1265e4aa
JB
896 mapping->encoded != NULL
897 && strncmp (mapping->decoded, p,
898 strlen (mapping->decoded)) != 0; mapping += 1)
4c4b4cd2
PH
899 ;
900 if (mapping->encoded == NULL)
323e0a4a 901 error (_("invalid Ada operator name: %s"), p);
4c4b4cd2
PH
902 strcpy (encoding_buffer + k, mapping->encoded);
903 k += strlen (mapping->encoded);
904 break;
905 }
d2e4a39e 906 else
4c4b4cd2
PH
907 {
908 encoding_buffer[k] = *p;
909 k += 1;
910 }
14f9c5c9
AS
911 }
912
4c4b4cd2
PH
913 encoding_buffer[k] = '\0';
914 return encoding_buffer;
14f9c5c9
AS
915}
916
917/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
918 quotes, unfolded, but with the quotes stripped away. Result good
919 to next call. */
920
d2e4a39e
AS
921char *
922ada_fold_name (const char *name)
14f9c5c9 923{
d2e4a39e 924 static char *fold_buffer = NULL;
14f9c5c9
AS
925 static size_t fold_buffer_size = 0;
926
927 int len = strlen (name);
d2e4a39e 928 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
929
930 if (name[0] == '\'')
931 {
d2e4a39e
AS
932 strncpy (fold_buffer, name + 1, len - 2);
933 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
934 }
935 else
936 {
937 int i;
5b4ee69b 938
14f9c5c9 939 for (i = 0; i <= len; i += 1)
4c4b4cd2 940 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
941 }
942
943 return fold_buffer;
944}
945
529cad9c
PH
946/* Return nonzero if C is either a digit or a lowercase alphabet character. */
947
948static int
949is_lower_alphanum (const char c)
950{
951 return (isdigit (c) || (isalpha (c) && islower (c)));
952}
953
c90092fe
JB
954/* ENCODED is the linkage name of a symbol and LEN contains its length.
955 This function saves in LEN the length of that same symbol name but
956 without either of these suffixes:
29480c32
JB
957 . .{DIGIT}+
958 . ${DIGIT}+
959 . ___{DIGIT}+
960 . __{DIGIT}+.
c90092fe 961
29480c32
JB
962 These are suffixes introduced by the compiler for entities such as
963 nested subprogram for instance, in order to avoid name clashes.
964 They do not serve any purpose for the debugger. */
965
966static void
967ada_remove_trailing_digits (const char *encoded, int *len)
968{
969 if (*len > 1 && isdigit (encoded[*len - 1]))
970 {
971 int i = *len - 2;
5b4ee69b 972
29480c32
JB
973 while (i > 0 && isdigit (encoded[i]))
974 i--;
975 if (i >= 0 && encoded[i] == '.')
976 *len = i;
977 else if (i >= 0 && encoded[i] == '$')
978 *len = i;
979 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
980 *len = i - 2;
981 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
982 *len = i - 1;
983 }
984}
985
986/* Remove the suffix introduced by the compiler for protected object
987 subprograms. */
988
989static void
990ada_remove_po_subprogram_suffix (const char *encoded, int *len)
991{
992 /* Remove trailing N. */
993
994 /* Protected entry subprograms are broken into two
995 separate subprograms: The first one is unprotected, and has
996 a 'N' suffix; the second is the protected version, and has
0963b4bd 997 the 'P' suffix. The second calls the first one after handling
29480c32
JB
998 the protection. Since the P subprograms are internally generated,
999 we leave these names undecoded, giving the user a clue that this
1000 entity is internal. */
1001
1002 if (*len > 1
1003 && encoded[*len - 1] == 'N'
1004 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1005 *len = *len - 1;
1006}
1007
69fadcdf
JB
1008/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1009
1010static void
1011ada_remove_Xbn_suffix (const char *encoded, int *len)
1012{
1013 int i = *len - 1;
1014
1015 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1016 i--;
1017
1018 if (encoded[i] != 'X')
1019 return;
1020
1021 if (i == 0)
1022 return;
1023
1024 if (isalnum (encoded[i-1]))
1025 *len = i;
1026}
1027
29480c32
JB
1028/* If ENCODED follows the GNAT entity encoding conventions, then return
1029 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1030 replaced by ENCODED.
14f9c5c9 1031
4c4b4cd2 1032 The resulting string is valid until the next call of ada_decode.
29480c32 1033 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1034 is returned. */
1035
1036const char *
1037ada_decode (const char *encoded)
14f9c5c9
AS
1038{
1039 int i, j;
1040 int len0;
d2e4a39e 1041 const char *p;
4c4b4cd2 1042 char *decoded;
14f9c5c9 1043 int at_start_name;
4c4b4cd2
PH
1044 static char *decoding_buffer = NULL;
1045 static size_t decoding_buffer_size = 0;
d2e4a39e 1046
29480c32
JB
1047 /* The name of the Ada main procedure starts with "_ada_".
1048 This prefix is not part of the decoded name, so skip this part
1049 if we see this prefix. */
4c4b4cd2
PH
1050 if (strncmp (encoded, "_ada_", 5) == 0)
1051 encoded += 5;
14f9c5c9 1052
29480c32
JB
1053 /* If the name starts with '_', then it is not a properly encoded
1054 name, so do not attempt to decode it. Similarly, if the name
1055 starts with '<', the name should not be decoded. */
4c4b4cd2 1056 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1057 goto Suppress;
1058
4c4b4cd2 1059 len0 = strlen (encoded);
4c4b4cd2 1060
29480c32
JB
1061 ada_remove_trailing_digits (encoded, &len0);
1062 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1063
4c4b4cd2
PH
1064 /* Remove the ___X.* suffix if present. Do not forget to verify that
1065 the suffix is located before the current "end" of ENCODED. We want
1066 to avoid re-matching parts of ENCODED that have previously been
1067 marked as discarded (by decrementing LEN0). */
1068 p = strstr (encoded, "___");
1069 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1070 {
1071 if (p[3] == 'X')
4c4b4cd2 1072 len0 = p - encoded;
14f9c5c9 1073 else
4c4b4cd2 1074 goto Suppress;
14f9c5c9 1075 }
4c4b4cd2 1076
29480c32
JB
1077 /* Remove any trailing TKB suffix. It tells us that this symbol
1078 is for the body of a task, but that information does not actually
1079 appear in the decoded name. */
1080
4c4b4cd2 1081 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
14f9c5c9 1082 len0 -= 3;
76a01679 1083
a10967fa
JB
1084 /* Remove any trailing TB suffix. The TB suffix is slightly different
1085 from the TKB suffix because it is used for non-anonymous task
1086 bodies. */
1087
1088 if (len0 > 2 && strncmp (encoded + len0 - 2, "TB", 2) == 0)
1089 len0 -= 2;
1090
29480c32
JB
1091 /* Remove trailing "B" suffixes. */
1092 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1093
4c4b4cd2 1094 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
14f9c5c9
AS
1095 len0 -= 1;
1096
4c4b4cd2 1097 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1098
4c4b4cd2
PH
1099 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1100 decoded = decoding_buffer;
14f9c5c9 1101
29480c32
JB
1102 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1103
4c4b4cd2 1104 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1105 {
4c4b4cd2
PH
1106 i = len0 - 2;
1107 while ((i >= 0 && isdigit (encoded[i]))
1108 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1109 i -= 1;
1110 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1111 len0 = i - 1;
1112 else if (encoded[i] == '$')
1113 len0 = i;
d2e4a39e 1114 }
14f9c5c9 1115
29480c32
JB
1116 /* The first few characters that are not alphabetic are not part
1117 of any encoding we use, so we can copy them over verbatim. */
1118
4c4b4cd2
PH
1119 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1120 decoded[j] = encoded[i];
14f9c5c9
AS
1121
1122 at_start_name = 1;
1123 while (i < len0)
1124 {
29480c32 1125 /* Is this a symbol function? */
4c4b4cd2
PH
1126 if (at_start_name && encoded[i] == 'O')
1127 {
1128 int k;
5b4ee69b 1129
4c4b4cd2
PH
1130 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1131 {
1132 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1133 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1134 op_len - 1) == 0)
1135 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1136 {
1137 strcpy (decoded + j, ada_opname_table[k].decoded);
1138 at_start_name = 0;
1139 i += op_len;
1140 j += strlen (ada_opname_table[k].decoded);
1141 break;
1142 }
1143 }
1144 if (ada_opname_table[k].encoded != NULL)
1145 continue;
1146 }
14f9c5c9
AS
1147 at_start_name = 0;
1148
529cad9c
PH
1149 /* Replace "TK__" with "__", which will eventually be translated
1150 into "." (just below). */
1151
4c4b4cd2
PH
1152 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
1153 i += 2;
529cad9c 1154
29480c32
JB
1155 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1156 be translated into "." (just below). These are internal names
1157 generated for anonymous blocks inside which our symbol is nested. */
1158
1159 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1160 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1161 && isdigit (encoded [i+4]))
1162 {
1163 int k = i + 5;
1164
1165 while (k < len0 && isdigit (encoded[k]))
1166 k++; /* Skip any extra digit. */
1167
1168 /* Double-check that the "__B_{DIGITS}+" sequence we found
1169 is indeed followed by "__". */
1170 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1171 i = k;
1172 }
1173
529cad9c
PH
1174 /* Remove _E{DIGITS}+[sb] */
1175
1176 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1177 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1178 one implements the actual entry code, and has a suffix following
1179 the convention above; the second one implements the barrier and
1180 uses the same convention as above, except that the 'E' is replaced
1181 by a 'B'.
1182
1183 Just as above, we do not decode the name of barrier functions
1184 to give the user a clue that the code he is debugging has been
1185 internally generated. */
1186
1187 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1188 && isdigit (encoded[i+2]))
1189 {
1190 int k = i + 3;
1191
1192 while (k < len0 && isdigit (encoded[k]))
1193 k++;
1194
1195 if (k < len0
1196 && (encoded[k] == 'b' || encoded[k] == 's'))
1197 {
1198 k++;
1199 /* Just as an extra precaution, make sure that if this
1200 suffix is followed by anything else, it is a '_'.
1201 Otherwise, we matched this sequence by accident. */
1202 if (k == len0
1203 || (k < len0 && encoded[k] == '_'))
1204 i = k;
1205 }
1206 }
1207
1208 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1209 the GNAT front-end in protected object subprograms. */
1210
1211 if (i < len0 + 3
1212 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1213 {
1214 /* Backtrack a bit up until we reach either the begining of
1215 the encoded name, or "__". Make sure that we only find
1216 digits or lowercase characters. */
1217 const char *ptr = encoded + i - 1;
1218
1219 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1220 ptr--;
1221 if (ptr < encoded
1222 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1223 i++;
1224 }
1225
4c4b4cd2
PH
1226 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1227 {
29480c32
JB
1228 /* This is a X[bn]* sequence not separated from the previous
1229 part of the name with a non-alpha-numeric character (in other
1230 words, immediately following an alpha-numeric character), then
1231 verify that it is placed at the end of the encoded name. If
1232 not, then the encoding is not valid and we should abort the
1233 decoding. Otherwise, just skip it, it is used in body-nested
1234 package names. */
4c4b4cd2
PH
1235 do
1236 i += 1;
1237 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1238 if (i < len0)
1239 goto Suppress;
1240 }
cdc7bb92 1241 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1242 {
29480c32 1243 /* Replace '__' by '.'. */
4c4b4cd2
PH
1244 decoded[j] = '.';
1245 at_start_name = 1;
1246 i += 2;
1247 j += 1;
1248 }
14f9c5c9 1249 else
4c4b4cd2 1250 {
29480c32
JB
1251 /* It's a character part of the decoded name, so just copy it
1252 over. */
4c4b4cd2
PH
1253 decoded[j] = encoded[i];
1254 i += 1;
1255 j += 1;
1256 }
14f9c5c9 1257 }
4c4b4cd2 1258 decoded[j] = '\000';
14f9c5c9 1259
29480c32
JB
1260 /* Decoded names should never contain any uppercase character.
1261 Double-check this, and abort the decoding if we find one. */
1262
4c4b4cd2
PH
1263 for (i = 0; decoded[i] != '\0'; i += 1)
1264 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1265 goto Suppress;
1266
4c4b4cd2
PH
1267 if (strcmp (decoded, encoded) == 0)
1268 return encoded;
1269 else
1270 return decoded;
14f9c5c9
AS
1271
1272Suppress:
4c4b4cd2
PH
1273 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1274 decoded = decoding_buffer;
1275 if (encoded[0] == '<')
1276 strcpy (decoded, encoded);
14f9c5c9 1277 else
88c15c34 1278 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1279 return decoded;
1280
1281}
1282
1283/* Table for keeping permanent unique copies of decoded names. Once
1284 allocated, names in this table are never released. While this is a
1285 storage leak, it should not be significant unless there are massive
1286 changes in the set of decoded names in successive versions of a
1287 symbol table loaded during a single session. */
1288static struct htab *decoded_names_store;
1289
1290/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1291 in the language-specific part of GSYMBOL, if it has not been
1292 previously computed. Tries to save the decoded name in the same
1293 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1294 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1295 GSYMBOL).
4c4b4cd2
PH
1296 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1297 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1298 when a decoded name is cached in it. */
4c4b4cd2 1299
45e6c716 1300const char *
f85f34ed 1301ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1302{
f85f34ed
TT
1303 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1304 const char **resultp =
1305 &gsymbol->language_specific.mangled_lang.demangled_name;
5b4ee69b 1306
f85f34ed 1307 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1308 {
1309 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1310 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1311
f85f34ed 1312 gsymbol->ada_mangled = 1;
5b4ee69b 1313
f85f34ed
TT
1314 if (obstack != NULL)
1315 *resultp = obstack_copy0 (obstack, decoded, strlen (decoded));
1316 else
76a01679 1317 {
f85f34ed
TT
1318 /* Sometimes, we can't find a corresponding objfile, in
1319 which case, we put the result on the heap. Since we only
1320 decode when needed, we hope this usually does not cause a
1321 significant memory leak (FIXME). */
1322
76a01679
JB
1323 char **slot = (char **) htab_find_slot (decoded_names_store,
1324 decoded, INSERT);
5b4ee69b 1325
76a01679
JB
1326 if (*slot == NULL)
1327 *slot = xstrdup (decoded);
1328 *resultp = *slot;
1329 }
4c4b4cd2 1330 }
14f9c5c9 1331
4c4b4cd2
PH
1332 return *resultp;
1333}
76a01679 1334
2c0b251b 1335static char *
76a01679 1336ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1337{
1338 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1339}
1340
1341/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
4c4b4cd2
PH
1342 suffixes that encode debugging information or leading _ada_ on
1343 SYM_NAME (see is_name_suffix commentary for the debugging
1344 information that is ignored). If WILD, then NAME need only match a
1345 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1346 either argument is NULL. */
14f9c5c9 1347
2c0b251b 1348static int
40658b94 1349match_name (const char *sym_name, const char *name, int wild)
14f9c5c9
AS
1350{
1351 if (sym_name == NULL || name == NULL)
1352 return 0;
1353 else if (wild)
73589123 1354 return wild_match (sym_name, name) == 0;
d2e4a39e
AS
1355 else
1356 {
1357 int len_name = strlen (name);
5b4ee69b 1358
4c4b4cd2
PH
1359 return (strncmp (sym_name, name, len_name) == 0
1360 && is_name_suffix (sym_name + len_name))
1361 || (strncmp (sym_name, "_ada_", 5) == 0
1362 && strncmp (sym_name + 5, name, len_name) == 0
1363 && is_name_suffix (sym_name + len_name + 5));
d2e4a39e 1364 }
14f9c5c9 1365}
14f9c5c9 1366\f
d2e4a39e 1367
4c4b4cd2 1368 /* Arrays */
14f9c5c9 1369
28c85d6c
JB
1370/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1371 generated by the GNAT compiler to describe the index type used
1372 for each dimension of an array, check whether it follows the latest
1373 known encoding. If not, fix it up to conform to the latest encoding.
1374 Otherwise, do nothing. This function also does nothing if
1375 INDEX_DESC_TYPE is NULL.
1376
1377 The GNAT encoding used to describle the array index type evolved a bit.
1378 Initially, the information would be provided through the name of each
1379 field of the structure type only, while the type of these fields was
1380 described as unspecified and irrelevant. The debugger was then expected
1381 to perform a global type lookup using the name of that field in order
1382 to get access to the full index type description. Because these global
1383 lookups can be very expensive, the encoding was later enhanced to make
1384 the global lookup unnecessary by defining the field type as being
1385 the full index type description.
1386
1387 The purpose of this routine is to allow us to support older versions
1388 of the compiler by detecting the use of the older encoding, and by
1389 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1390 we essentially replace each field's meaningless type by the associated
1391 index subtype). */
1392
1393void
1394ada_fixup_array_indexes_type (struct type *index_desc_type)
1395{
1396 int i;
1397
1398 if (index_desc_type == NULL)
1399 return;
1400 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1401
1402 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1403 to check one field only, no need to check them all). If not, return
1404 now.
1405
1406 If our INDEX_DESC_TYPE was generated using the older encoding,
1407 the field type should be a meaningless integer type whose name
1408 is not equal to the field name. */
1409 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1410 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1411 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1412 return;
1413
1414 /* Fixup each field of INDEX_DESC_TYPE. */
1415 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1416 {
0d5cff50 1417 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1418 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1419
1420 if (raw_type)
1421 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1422 }
1423}
1424
4c4b4cd2 1425/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1426
d2e4a39e
AS
1427static char *bound_name[] = {
1428 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1429 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1430};
1431
1432/* Maximum number of array dimensions we are prepared to handle. */
1433
4c4b4cd2 1434#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1435
14f9c5c9 1436
4c4b4cd2
PH
1437/* The desc_* routines return primitive portions of array descriptors
1438 (fat pointers). */
14f9c5c9
AS
1439
1440/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1441 level of indirection, if needed. */
1442
d2e4a39e
AS
1443static struct type *
1444desc_base_type (struct type *type)
14f9c5c9
AS
1445{
1446 if (type == NULL)
1447 return NULL;
61ee279c 1448 type = ada_check_typedef (type);
720d1a40
JB
1449 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1450 type = ada_typedef_target_type (type);
1451
1265e4aa
JB
1452 if (type != NULL
1453 && (TYPE_CODE (type) == TYPE_CODE_PTR
1454 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1455 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1456 else
1457 return type;
1458}
1459
4c4b4cd2
PH
1460/* True iff TYPE indicates a "thin" array pointer type. */
1461
14f9c5c9 1462static int
d2e4a39e 1463is_thin_pntr (struct type *type)
14f9c5c9 1464{
d2e4a39e 1465 return
14f9c5c9
AS
1466 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1467 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1468}
1469
4c4b4cd2
PH
1470/* The descriptor type for thin pointer type TYPE. */
1471
d2e4a39e
AS
1472static struct type *
1473thin_descriptor_type (struct type *type)
14f9c5c9 1474{
d2e4a39e 1475 struct type *base_type = desc_base_type (type);
5b4ee69b 1476
14f9c5c9
AS
1477 if (base_type == NULL)
1478 return NULL;
1479 if (is_suffix (ada_type_name (base_type), "___XVE"))
1480 return base_type;
d2e4a39e 1481 else
14f9c5c9 1482 {
d2e4a39e 1483 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1484
14f9c5c9 1485 if (alt_type == NULL)
4c4b4cd2 1486 return base_type;
14f9c5c9 1487 else
4c4b4cd2 1488 return alt_type;
14f9c5c9
AS
1489 }
1490}
1491
4c4b4cd2
PH
1492/* A pointer to the array data for thin-pointer value VAL. */
1493
d2e4a39e
AS
1494static struct value *
1495thin_data_pntr (struct value *val)
14f9c5c9 1496{
828292f2 1497 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1498 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1499
556bdfd4
UW
1500 data_type = lookup_pointer_type (data_type);
1501
14f9c5c9 1502 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1503 return value_cast (data_type, value_copy (val));
d2e4a39e 1504 else
42ae5230 1505 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1506}
1507
4c4b4cd2
PH
1508/* True iff TYPE indicates a "thick" array pointer type. */
1509
14f9c5c9 1510static int
d2e4a39e 1511is_thick_pntr (struct type *type)
14f9c5c9
AS
1512{
1513 type = desc_base_type (type);
1514 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1515 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1516}
1517
4c4b4cd2
PH
1518/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1519 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1520
d2e4a39e
AS
1521static struct type *
1522desc_bounds_type (struct type *type)
14f9c5c9 1523{
d2e4a39e 1524 struct type *r;
14f9c5c9
AS
1525
1526 type = desc_base_type (type);
1527
1528 if (type == NULL)
1529 return NULL;
1530 else if (is_thin_pntr (type))
1531 {
1532 type = thin_descriptor_type (type);
1533 if (type == NULL)
4c4b4cd2 1534 return NULL;
14f9c5c9
AS
1535 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1536 if (r != NULL)
61ee279c 1537 return ada_check_typedef (r);
14f9c5c9
AS
1538 }
1539 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1540 {
1541 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1542 if (r != NULL)
61ee279c 1543 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1544 }
1545 return NULL;
1546}
1547
1548/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1549 one, a pointer to its bounds data. Otherwise NULL. */
1550
d2e4a39e
AS
1551static struct value *
1552desc_bounds (struct value *arr)
14f9c5c9 1553{
df407dfe 1554 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1555
d2e4a39e 1556 if (is_thin_pntr (type))
14f9c5c9 1557 {
d2e4a39e 1558 struct type *bounds_type =
4c4b4cd2 1559 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1560 LONGEST addr;
1561
4cdfadb1 1562 if (bounds_type == NULL)
323e0a4a 1563 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1564
1565 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1566 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1567 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1568 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1569 addr = value_as_long (arr);
d2e4a39e 1570 else
42ae5230 1571 addr = value_address (arr);
14f9c5c9 1572
d2e4a39e 1573 return
4c4b4cd2
PH
1574 value_from_longest (lookup_pointer_type (bounds_type),
1575 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1576 }
1577
1578 else if (is_thick_pntr (type))
05e522ef
JB
1579 {
1580 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1581 _("Bad GNAT array descriptor"));
1582 struct type *p_bounds_type = value_type (p_bounds);
1583
1584 if (p_bounds_type
1585 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1586 {
1587 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1588
1589 if (TYPE_STUB (target_type))
1590 p_bounds = value_cast (lookup_pointer_type
1591 (ada_check_typedef (target_type)),
1592 p_bounds);
1593 }
1594 else
1595 error (_("Bad GNAT array descriptor"));
1596
1597 return p_bounds;
1598 }
14f9c5c9
AS
1599 else
1600 return NULL;
1601}
1602
4c4b4cd2
PH
1603/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1604 position of the field containing the address of the bounds data. */
1605
14f9c5c9 1606static int
d2e4a39e 1607fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1608{
1609 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1610}
1611
1612/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1613 size of the field containing the address of the bounds data. */
1614
14f9c5c9 1615static int
d2e4a39e 1616fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1617{
1618 type = desc_base_type (type);
1619
d2e4a39e 1620 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1621 return TYPE_FIELD_BITSIZE (type, 1);
1622 else
61ee279c 1623 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1624}
1625
4c4b4cd2 1626/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1627 pointer to one, the type of its array data (a array-with-no-bounds type);
1628 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1629 data. */
4c4b4cd2 1630
d2e4a39e 1631static struct type *
556bdfd4 1632desc_data_target_type (struct type *type)
14f9c5c9
AS
1633{
1634 type = desc_base_type (type);
1635
4c4b4cd2 1636 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1637 if (is_thin_pntr (type))
556bdfd4 1638 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1639 else if (is_thick_pntr (type))
556bdfd4
UW
1640 {
1641 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1642
1643 if (data_type
1644 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1645 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1646 }
1647
1648 return NULL;
14f9c5c9
AS
1649}
1650
1651/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1652 its array data. */
4c4b4cd2 1653
d2e4a39e
AS
1654static struct value *
1655desc_data (struct value *arr)
14f9c5c9 1656{
df407dfe 1657 struct type *type = value_type (arr);
5b4ee69b 1658
14f9c5c9
AS
1659 if (is_thin_pntr (type))
1660 return thin_data_pntr (arr);
1661 else if (is_thick_pntr (type))
d2e4a39e 1662 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1663 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1664 else
1665 return NULL;
1666}
1667
1668
1669/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1670 position of the field containing the address of the data. */
1671
14f9c5c9 1672static int
d2e4a39e 1673fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1674{
1675 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1676}
1677
1678/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1679 size of the field containing the address of the data. */
1680
14f9c5c9 1681static int
d2e4a39e 1682fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1683{
1684 type = desc_base_type (type);
1685
1686 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1687 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1688 else
14f9c5c9
AS
1689 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1690}
1691
4c4b4cd2 1692/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1693 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1694 bound, if WHICH is 1. The first bound is I=1. */
1695
d2e4a39e
AS
1696static struct value *
1697desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1698{
d2e4a39e 1699 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1700 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1701}
1702
1703/* If BOUNDS is an array-bounds structure type, return the bit position
1704 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1705 bound, if WHICH is 1. The first bound is I=1. */
1706
14f9c5c9 1707static int
d2e4a39e 1708desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1709{
d2e4a39e 1710 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1711}
1712
1713/* If BOUNDS is an array-bounds structure type, return the bit field size
1714 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1715 bound, if WHICH is 1. The first bound is I=1. */
1716
76a01679 1717static int
d2e4a39e 1718desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1719{
1720 type = desc_base_type (type);
1721
d2e4a39e
AS
1722 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1723 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1724 else
1725 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1726}
1727
1728/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1729 Ith bound (numbering from 1). Otherwise, NULL. */
1730
d2e4a39e
AS
1731static struct type *
1732desc_index_type (struct type *type, int i)
14f9c5c9
AS
1733{
1734 type = desc_base_type (type);
1735
1736 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1737 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1738 else
14f9c5c9
AS
1739 return NULL;
1740}
1741
4c4b4cd2
PH
1742/* The number of index positions in the array-bounds type TYPE.
1743 Return 0 if TYPE is NULL. */
1744
14f9c5c9 1745static int
d2e4a39e 1746desc_arity (struct type *type)
14f9c5c9
AS
1747{
1748 type = desc_base_type (type);
1749
1750 if (type != NULL)
1751 return TYPE_NFIELDS (type) / 2;
1752 return 0;
1753}
1754
4c4b4cd2
PH
1755/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1756 an array descriptor type (representing an unconstrained array
1757 type). */
1758
76a01679
JB
1759static int
1760ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1761{
1762 if (type == NULL)
1763 return 0;
61ee279c 1764 type = ada_check_typedef (type);
4c4b4cd2 1765 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1766 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1767}
1768
52ce6436 1769/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1770 * to one. */
52ce6436 1771
2c0b251b 1772static int
52ce6436
PH
1773ada_is_array_type (struct type *type)
1774{
1775 while (type != NULL
1776 && (TYPE_CODE (type) == TYPE_CODE_PTR
1777 || TYPE_CODE (type) == TYPE_CODE_REF))
1778 type = TYPE_TARGET_TYPE (type);
1779 return ada_is_direct_array_type (type);
1780}
1781
4c4b4cd2 1782/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1783
14f9c5c9 1784int
4c4b4cd2 1785ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1786{
1787 if (type == NULL)
1788 return 0;
61ee279c 1789 type = ada_check_typedef (type);
14f9c5c9 1790 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1791 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1792 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1793 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1794}
1795
4c4b4cd2
PH
1796/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1797
14f9c5c9 1798int
4c4b4cd2 1799ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1800{
556bdfd4 1801 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1802
1803 if (type == NULL)
1804 return 0;
61ee279c 1805 type = ada_check_typedef (type);
556bdfd4
UW
1806 return (data_type != NULL
1807 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1808 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1809}
1810
1811/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1812 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1813 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1814 is still needed. */
1815
14f9c5c9 1816int
ebf56fd3 1817ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1818{
d2e4a39e 1819 return
14f9c5c9
AS
1820 type != NULL
1821 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1822 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1823 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1824 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1825}
1826
1827
4c4b4cd2 1828/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1829 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1830 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1831 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1832 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1833 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1834 a descriptor. */
d2e4a39e
AS
1835struct type *
1836ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1837{
ad82864c
JB
1838 if (ada_is_constrained_packed_array_type (value_type (arr)))
1839 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1840
df407dfe
AC
1841 if (!ada_is_array_descriptor_type (value_type (arr)))
1842 return value_type (arr);
d2e4a39e
AS
1843
1844 if (!bounds)
ad82864c
JB
1845 {
1846 struct type *array_type =
1847 ada_check_typedef (desc_data_target_type (value_type (arr)));
1848
1849 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1850 TYPE_FIELD_BITSIZE (array_type, 0) =
1851 decode_packed_array_bitsize (value_type (arr));
1852
1853 return array_type;
1854 }
14f9c5c9
AS
1855 else
1856 {
d2e4a39e 1857 struct type *elt_type;
14f9c5c9 1858 int arity;
d2e4a39e 1859 struct value *descriptor;
14f9c5c9 1860
df407dfe
AC
1861 elt_type = ada_array_element_type (value_type (arr), -1);
1862 arity = ada_array_arity (value_type (arr));
14f9c5c9 1863
d2e4a39e 1864 if (elt_type == NULL || arity == 0)
df407dfe 1865 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
1866
1867 descriptor = desc_bounds (arr);
d2e4a39e 1868 if (value_as_long (descriptor) == 0)
4c4b4cd2 1869 return NULL;
d2e4a39e 1870 while (arity > 0)
4c4b4cd2 1871 {
e9bb382b
UW
1872 struct type *range_type = alloc_type_copy (value_type (arr));
1873 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
1874 struct value *low = desc_one_bound (descriptor, arity, 0);
1875 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 1876
5b4ee69b 1877 arity -= 1;
df407dfe 1878 create_range_type (range_type, value_type (low),
529cad9c
PH
1879 longest_to_int (value_as_long (low)),
1880 longest_to_int (value_as_long (high)));
4c4b4cd2 1881 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
1882
1883 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
1884 {
1885 /* We need to store the element packed bitsize, as well as
1886 recompute the array size, because it was previously
1887 computed based on the unpacked element size. */
1888 LONGEST lo = value_as_long (low);
1889 LONGEST hi = value_as_long (high);
1890
1891 TYPE_FIELD_BITSIZE (elt_type, 0) =
1892 decode_packed_array_bitsize (value_type (arr));
1893 /* If the array has no element, then the size is already
1894 zero, and does not need to be recomputed. */
1895 if (lo < hi)
1896 {
1897 int array_bitsize =
1898 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1899
1900 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
1901 }
1902 }
4c4b4cd2 1903 }
14f9c5c9
AS
1904
1905 return lookup_pointer_type (elt_type);
1906 }
1907}
1908
1909/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
1910 Otherwise, returns either a standard GDB array with bounds set
1911 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1912 GDB array. Returns NULL if ARR is a null fat pointer. */
1913
d2e4a39e
AS
1914struct value *
1915ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 1916{
df407dfe 1917 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 1918 {
d2e4a39e 1919 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 1920
14f9c5c9 1921 if (arrType == NULL)
4c4b4cd2 1922 return NULL;
14f9c5c9
AS
1923 return value_cast (arrType, value_copy (desc_data (arr)));
1924 }
ad82864c
JB
1925 else if (ada_is_constrained_packed_array_type (value_type (arr)))
1926 return decode_constrained_packed_array (arr);
14f9c5c9
AS
1927 else
1928 return arr;
1929}
1930
1931/* If ARR does not represent an array, returns ARR unchanged.
1932 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
1933 be ARR itself if it already is in the proper form). */
1934
720d1a40 1935struct value *
d2e4a39e 1936ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 1937{
df407dfe 1938 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 1939 {
d2e4a39e 1940 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 1941
14f9c5c9 1942 if (arrVal == NULL)
323e0a4a 1943 error (_("Bounds unavailable for null array pointer."));
529cad9c 1944 check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
1945 return value_ind (arrVal);
1946 }
ad82864c
JB
1947 else if (ada_is_constrained_packed_array_type (value_type (arr)))
1948 return decode_constrained_packed_array (arr);
d2e4a39e 1949 else
14f9c5c9
AS
1950 return arr;
1951}
1952
1953/* If TYPE represents a GNAT array type, return it translated to an
1954 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
1955 packing). For other types, is the identity. */
1956
d2e4a39e
AS
1957struct type *
1958ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 1959{
ad82864c
JB
1960 if (ada_is_constrained_packed_array_type (type))
1961 return decode_constrained_packed_array_type (type);
17280b9f
UW
1962
1963 if (ada_is_array_descriptor_type (type))
556bdfd4 1964 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
1965
1966 return type;
14f9c5c9
AS
1967}
1968
4c4b4cd2
PH
1969/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1970
ad82864c
JB
1971static int
1972ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
1973{
1974 if (type == NULL)
1975 return 0;
4c4b4cd2 1976 type = desc_base_type (type);
61ee279c 1977 type = ada_check_typedef (type);
d2e4a39e 1978 return
14f9c5c9
AS
1979 ada_type_name (type) != NULL
1980 && strstr (ada_type_name (type), "___XP") != NULL;
1981}
1982
ad82864c
JB
1983/* Non-zero iff TYPE represents a standard GNAT constrained
1984 packed-array type. */
1985
1986int
1987ada_is_constrained_packed_array_type (struct type *type)
1988{
1989 return ada_is_packed_array_type (type)
1990 && !ada_is_array_descriptor_type (type);
1991}
1992
1993/* Non-zero iff TYPE represents an array descriptor for a
1994 unconstrained packed-array type. */
1995
1996static int
1997ada_is_unconstrained_packed_array_type (struct type *type)
1998{
1999 return ada_is_packed_array_type (type)
2000 && ada_is_array_descriptor_type (type);
2001}
2002
2003/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2004 return the size of its elements in bits. */
2005
2006static long
2007decode_packed_array_bitsize (struct type *type)
2008{
0d5cff50
DE
2009 const char *raw_name;
2010 const char *tail;
ad82864c
JB
2011 long bits;
2012
720d1a40
JB
2013 /* Access to arrays implemented as fat pointers are encoded as a typedef
2014 of the fat pointer type. We need the name of the fat pointer type
2015 to do the decoding, so strip the typedef layer. */
2016 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2017 type = ada_typedef_target_type (type);
2018
2019 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2020 if (!raw_name)
2021 raw_name = ada_type_name (desc_base_type (type));
2022
2023 if (!raw_name)
2024 return 0;
2025
2026 tail = strstr (raw_name, "___XP");
720d1a40 2027 gdb_assert (tail != NULL);
ad82864c
JB
2028
2029 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2030 {
2031 lim_warning
2032 (_("could not understand bit size information on packed array"));
2033 return 0;
2034 }
2035
2036 return bits;
2037}
2038
14f9c5c9
AS
2039/* Given that TYPE is a standard GDB array type with all bounds filled
2040 in, and that the element size of its ultimate scalar constituents
2041 (that is, either its elements, or, if it is an array of arrays, its
2042 elements' elements, etc.) is *ELT_BITS, return an identical type,
2043 but with the bit sizes of its elements (and those of any
2044 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2
PH
2045 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2046 in bits. */
2047
d2e4a39e 2048static struct type *
ad82864c 2049constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2050{
d2e4a39e
AS
2051 struct type *new_elt_type;
2052 struct type *new_type;
99b1c762
JB
2053 struct type *index_type_desc;
2054 struct type *index_type;
14f9c5c9
AS
2055 LONGEST low_bound, high_bound;
2056
61ee279c 2057 type = ada_check_typedef (type);
14f9c5c9
AS
2058 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2059 return type;
2060
99b1c762
JB
2061 index_type_desc = ada_find_parallel_type (type, "___XA");
2062 if (index_type_desc)
2063 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2064 NULL);
2065 else
2066 index_type = TYPE_INDEX_TYPE (type);
2067
e9bb382b 2068 new_type = alloc_type_copy (type);
ad82864c
JB
2069 new_elt_type =
2070 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2071 elt_bits);
99b1c762 2072 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2073 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2074 TYPE_NAME (new_type) = ada_type_name (type);
2075
99b1c762 2076 if (get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2077 low_bound = high_bound = 0;
2078 if (high_bound < low_bound)
2079 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2080 else
14f9c5c9
AS
2081 {
2082 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2083 TYPE_LENGTH (new_type) =
4c4b4cd2 2084 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2085 }
2086
876cecd0 2087 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2088 return new_type;
2089}
2090
ad82864c
JB
2091/* The array type encoded by TYPE, where
2092 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2093
d2e4a39e 2094static struct type *
ad82864c 2095decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2096{
0d5cff50 2097 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2098 char *name;
0d5cff50 2099 const char *tail;
d2e4a39e 2100 struct type *shadow_type;
14f9c5c9 2101 long bits;
14f9c5c9 2102
727e3d2e
JB
2103 if (!raw_name)
2104 raw_name = ada_type_name (desc_base_type (type));
2105
2106 if (!raw_name)
2107 return NULL;
2108
2109 name = (char *) alloca (strlen (raw_name) + 1);
2110 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2111 type = desc_base_type (type);
2112
14f9c5c9
AS
2113 memcpy (name, raw_name, tail - raw_name);
2114 name[tail - raw_name] = '\000';
2115
b4ba55a1
JB
2116 shadow_type = ada_find_parallel_type_with_name (type, name);
2117
2118 if (shadow_type == NULL)
14f9c5c9 2119 {
323e0a4a 2120 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2121 return NULL;
2122 }
cb249c71 2123 CHECK_TYPEDEF (shadow_type);
14f9c5c9
AS
2124
2125 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2126 {
0963b4bd
MS
2127 lim_warning (_("could not understand bounds "
2128 "information on packed array"));
14f9c5c9
AS
2129 return NULL;
2130 }
d2e4a39e 2131
ad82864c
JB
2132 bits = decode_packed_array_bitsize (type);
2133 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2134}
2135
ad82864c
JB
2136/* Given that ARR is a struct value *indicating a GNAT constrained packed
2137 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2138 standard GDB array type except that the BITSIZEs of the array
2139 target types are set to the number of bits in each element, and the
4c4b4cd2 2140 type length is set appropriately. */
14f9c5c9 2141
d2e4a39e 2142static struct value *
ad82864c 2143decode_constrained_packed_array (struct value *arr)
14f9c5c9 2144{
4c4b4cd2 2145 struct type *type;
14f9c5c9 2146
4c4b4cd2 2147 arr = ada_coerce_ref (arr);
284614f0
JB
2148
2149 /* If our value is a pointer, then dererence it. Make sure that
2150 this operation does not cause the target type to be fixed, as
2151 this would indirectly cause this array to be decoded. The rest
2152 of the routine assumes that the array hasn't been decoded yet,
2153 so we use the basic "value_ind" routine to perform the dereferencing,
2154 as opposed to using "ada_value_ind". */
828292f2 2155 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2156 arr = value_ind (arr);
4c4b4cd2 2157
ad82864c 2158 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2159 if (type == NULL)
2160 {
323e0a4a 2161 error (_("can't unpack array"));
14f9c5c9
AS
2162 return NULL;
2163 }
61ee279c 2164
50810684 2165 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2166 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2167 {
2168 /* This is a (right-justified) modular type representing a packed
2169 array with no wrapper. In order to interpret the value through
2170 the (left-justified) packed array type we just built, we must
2171 first left-justify it. */
2172 int bit_size, bit_pos;
2173 ULONGEST mod;
2174
df407dfe 2175 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2176 bit_size = 0;
2177 while (mod > 0)
2178 {
2179 bit_size += 1;
2180 mod >>= 1;
2181 }
df407dfe 2182 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2183 arr = ada_value_primitive_packed_val (arr, NULL,
2184 bit_pos / HOST_CHAR_BIT,
2185 bit_pos % HOST_CHAR_BIT,
2186 bit_size,
2187 type);
2188 }
2189
4c4b4cd2 2190 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2191}
2192
2193
2194/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2195 given in IND. ARR must be a simple array. */
14f9c5c9 2196
d2e4a39e
AS
2197static struct value *
2198value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2199{
2200 int i;
2201 int bits, elt_off, bit_off;
2202 long elt_total_bit_offset;
d2e4a39e
AS
2203 struct type *elt_type;
2204 struct value *v;
14f9c5c9
AS
2205
2206 bits = 0;
2207 elt_total_bit_offset = 0;
df407dfe 2208 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2209 for (i = 0; i < arity; i += 1)
14f9c5c9 2210 {
d2e4a39e 2211 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2212 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2213 error
0963b4bd
MS
2214 (_("attempt to do packed indexing of "
2215 "something other than a packed array"));
14f9c5c9 2216 else
4c4b4cd2
PH
2217 {
2218 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2219 LONGEST lowerbound, upperbound;
2220 LONGEST idx;
2221
2222 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2223 {
323e0a4a 2224 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2225 lowerbound = upperbound = 0;
2226 }
2227
3cb382c9 2228 idx = pos_atr (ind[i]);
4c4b4cd2 2229 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2230 lim_warning (_("packed array index %ld out of bounds"),
2231 (long) idx);
4c4b4cd2
PH
2232 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2233 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2234 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2235 }
14f9c5c9
AS
2236 }
2237 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2238 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2239
2240 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2241 bits, elt_type);
14f9c5c9
AS
2242 return v;
2243}
2244
4c4b4cd2 2245/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2246
2247static int
d2e4a39e 2248has_negatives (struct type *type)
14f9c5c9 2249{
d2e4a39e
AS
2250 switch (TYPE_CODE (type))
2251 {
2252 default:
2253 return 0;
2254 case TYPE_CODE_INT:
2255 return !TYPE_UNSIGNED (type);
2256 case TYPE_CODE_RANGE:
2257 return TYPE_LOW_BOUND (type) < 0;
2258 }
14f9c5c9 2259}
d2e4a39e 2260
14f9c5c9
AS
2261
2262/* Create a new value of type TYPE from the contents of OBJ starting
2263 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2264 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
0963b4bd 2265 assigning through the result will set the field fetched from.
4c4b4cd2
PH
2266 VALADDR is ignored unless OBJ is NULL, in which case,
2267 VALADDR+OFFSET must address the start of storage containing the
2268 packed value. The value returned in this case is never an lval.
2269 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
14f9c5c9 2270
d2e4a39e 2271struct value *
fc1a4b47 2272ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
a2bd3dcd 2273 long offset, int bit_offset, int bit_size,
4c4b4cd2 2274 struct type *type)
14f9c5c9 2275{
d2e4a39e 2276 struct value *v;
4c4b4cd2
PH
2277 int src, /* Index into the source area */
2278 targ, /* Index into the target area */
2279 srcBitsLeft, /* Number of source bits left to move */
2280 nsrc, ntarg, /* Number of source and target bytes */
2281 unusedLS, /* Number of bits in next significant
2282 byte of source that are unused */
2283 accumSize; /* Number of meaningful bits in accum */
2284 unsigned char *bytes; /* First byte containing data to unpack */
d2e4a39e 2285 unsigned char *unpacked;
4c4b4cd2 2286 unsigned long accum; /* Staging area for bits being transferred */
14f9c5c9
AS
2287 unsigned char sign;
2288 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
4c4b4cd2
PH
2289 /* Transmit bytes from least to most significant; delta is the direction
2290 the indices move. */
50810684 2291 int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1;
14f9c5c9 2292
61ee279c 2293 type = ada_check_typedef (type);
14f9c5c9
AS
2294
2295 if (obj == NULL)
2296 {
2297 v = allocate_value (type);
d2e4a39e 2298 bytes = (unsigned char *) (valaddr + offset);
14f9c5c9 2299 }
9214ee5f 2300 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
14f9c5c9 2301 {
53ba8333 2302 v = value_at (type, value_address (obj));
d2e4a39e 2303 bytes = (unsigned char *) alloca (len);
53ba8333 2304 read_memory (value_address (v) + offset, bytes, len);
14f9c5c9 2305 }
d2e4a39e 2306 else
14f9c5c9
AS
2307 {
2308 v = allocate_value (type);
0fd88904 2309 bytes = (unsigned char *) value_contents (obj) + offset;
14f9c5c9 2310 }
d2e4a39e
AS
2311
2312 if (obj != NULL)
14f9c5c9 2313 {
53ba8333 2314 long new_offset = offset;
5b4ee69b 2315
74bcbdf3 2316 set_value_component_location (v, obj);
9bbda503
AC
2317 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2318 set_value_bitsize (v, bit_size);
df407dfe 2319 if (value_bitpos (v) >= HOST_CHAR_BIT)
4c4b4cd2 2320 {
53ba8333 2321 ++new_offset;
9bbda503 2322 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
4c4b4cd2 2323 }
53ba8333
JB
2324 set_value_offset (v, new_offset);
2325
2326 /* Also set the parent value. This is needed when trying to
2327 assign a new value (in inferior memory). */
2328 set_value_parent (v, obj);
14f9c5c9
AS
2329 }
2330 else
9bbda503 2331 set_value_bitsize (v, bit_size);
0fd88904 2332 unpacked = (unsigned char *) value_contents (v);
14f9c5c9
AS
2333
2334 srcBitsLeft = bit_size;
2335 nsrc = len;
2336 ntarg = TYPE_LENGTH (type);
2337 sign = 0;
2338 if (bit_size == 0)
2339 {
2340 memset (unpacked, 0, TYPE_LENGTH (type));
2341 return v;
2342 }
50810684 2343 else if (gdbarch_bits_big_endian (get_type_arch (type)))
14f9c5c9 2344 {
d2e4a39e 2345 src = len - 1;
1265e4aa
JB
2346 if (has_negatives (type)
2347 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2348 sign = ~0;
d2e4a39e
AS
2349
2350 unusedLS =
4c4b4cd2
PH
2351 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2352 % HOST_CHAR_BIT;
14f9c5c9
AS
2353
2354 switch (TYPE_CODE (type))
4c4b4cd2
PH
2355 {
2356 case TYPE_CODE_ARRAY:
2357 case TYPE_CODE_UNION:
2358 case TYPE_CODE_STRUCT:
2359 /* Non-scalar values must be aligned at a byte boundary... */
2360 accumSize =
2361 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2362 /* ... And are placed at the beginning (most-significant) bytes
2363 of the target. */
529cad9c 2364 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
0056e4d5 2365 ntarg = targ + 1;
4c4b4cd2
PH
2366 break;
2367 default:
2368 accumSize = 0;
2369 targ = TYPE_LENGTH (type) - 1;
2370 break;
2371 }
14f9c5c9 2372 }
d2e4a39e 2373 else
14f9c5c9
AS
2374 {
2375 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2376
2377 src = targ = 0;
2378 unusedLS = bit_offset;
2379 accumSize = 0;
2380
d2e4a39e 2381 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2382 sign = ~0;
14f9c5c9 2383 }
d2e4a39e 2384
14f9c5c9
AS
2385 accum = 0;
2386 while (nsrc > 0)
2387 {
2388 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2389 part of the value. */
d2e4a39e 2390 unsigned int unusedMSMask =
4c4b4cd2
PH
2391 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2392 1;
2393 /* Sign-extend bits for this byte. */
14f9c5c9 2394 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2395
d2e4a39e 2396 accum |=
4c4b4cd2 2397 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2398 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2399 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2
PH
2400 {
2401 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2402 accumSize -= HOST_CHAR_BIT;
2403 accum >>= HOST_CHAR_BIT;
2404 ntarg -= 1;
2405 targ += delta;
2406 }
14f9c5c9
AS
2407 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2408 unusedLS = 0;
2409 nsrc -= 1;
2410 src += delta;
2411 }
2412 while (ntarg > 0)
2413 {
2414 accum |= sign << accumSize;
2415 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2416 accumSize -= HOST_CHAR_BIT;
2417 accum >>= HOST_CHAR_BIT;
2418 ntarg -= 1;
2419 targ += delta;
2420 }
2421
2422 return v;
2423}
d2e4a39e 2424
14f9c5c9
AS
2425/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2426 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2427 not overlap. */
14f9c5c9 2428static void
fc1a4b47 2429move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2430 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2431{
2432 unsigned int accum, mask;
2433 int accum_bits, chunk_size;
2434
2435 target += targ_offset / HOST_CHAR_BIT;
2436 targ_offset %= HOST_CHAR_BIT;
2437 source += src_offset / HOST_CHAR_BIT;
2438 src_offset %= HOST_CHAR_BIT;
50810684 2439 if (bits_big_endian_p)
14f9c5c9
AS
2440 {
2441 accum = (unsigned char) *source;
2442 source += 1;
2443 accum_bits = HOST_CHAR_BIT - src_offset;
2444
d2e4a39e 2445 while (n > 0)
4c4b4cd2
PH
2446 {
2447 int unused_right;
5b4ee69b 2448
4c4b4cd2
PH
2449 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2450 accum_bits += HOST_CHAR_BIT;
2451 source += 1;
2452 chunk_size = HOST_CHAR_BIT - targ_offset;
2453 if (chunk_size > n)
2454 chunk_size = n;
2455 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2456 mask = ((1 << chunk_size) - 1) << unused_right;
2457 *target =
2458 (*target & ~mask)
2459 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2460 n -= chunk_size;
2461 accum_bits -= chunk_size;
2462 target += 1;
2463 targ_offset = 0;
2464 }
14f9c5c9
AS
2465 }
2466 else
2467 {
2468 accum = (unsigned char) *source >> src_offset;
2469 source += 1;
2470 accum_bits = HOST_CHAR_BIT - src_offset;
2471
d2e4a39e 2472 while (n > 0)
4c4b4cd2
PH
2473 {
2474 accum = accum + ((unsigned char) *source << accum_bits);
2475 accum_bits += HOST_CHAR_BIT;
2476 source += 1;
2477 chunk_size = HOST_CHAR_BIT - targ_offset;
2478 if (chunk_size > n)
2479 chunk_size = n;
2480 mask = ((1 << chunk_size) - 1) << targ_offset;
2481 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2482 n -= chunk_size;
2483 accum_bits -= chunk_size;
2484 accum >>= chunk_size;
2485 target += 1;
2486 targ_offset = 0;
2487 }
14f9c5c9
AS
2488 }
2489}
2490
14f9c5c9
AS
2491/* Store the contents of FROMVAL into the location of TOVAL.
2492 Return a new value with the location of TOVAL and contents of
2493 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2494 floating-point or non-scalar types. */
14f9c5c9 2495
d2e4a39e
AS
2496static struct value *
2497ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2498{
df407dfe
AC
2499 struct type *type = value_type (toval);
2500 int bits = value_bitsize (toval);
14f9c5c9 2501
52ce6436
PH
2502 toval = ada_coerce_ref (toval);
2503 fromval = ada_coerce_ref (fromval);
2504
2505 if (ada_is_direct_array_type (value_type (toval)))
2506 toval = ada_coerce_to_simple_array (toval);
2507 if (ada_is_direct_array_type (value_type (fromval)))
2508 fromval = ada_coerce_to_simple_array (fromval);
2509
88e3b34b 2510 if (!deprecated_value_modifiable (toval))
323e0a4a 2511 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2512
d2e4a39e 2513 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2514 && bits > 0
d2e4a39e 2515 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2516 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2517 {
df407dfe
AC
2518 int len = (value_bitpos (toval)
2519 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2520 int from_size;
948f8e3d 2521 gdb_byte *buffer = alloca (len);
d2e4a39e 2522 struct value *val;
42ae5230 2523 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2524
2525 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2526 fromval = value_cast (type, fromval);
14f9c5c9 2527
52ce6436 2528 read_memory (to_addr, buffer, len);
aced2898
PH
2529 from_size = value_bitsize (fromval);
2530 if (from_size == 0)
2531 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2532 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2533 move_bits (buffer, value_bitpos (toval),
50810684 2534 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2535 else
50810684
UW
2536 move_bits (buffer, value_bitpos (toval),
2537 value_contents (fromval), 0, bits, 0);
972daa01 2538 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2539
14f9c5c9 2540 val = value_copy (toval);
0fd88904 2541 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2542 TYPE_LENGTH (type));
04624583 2543 deprecated_set_value_type (val, type);
d2e4a39e 2544
14f9c5c9
AS
2545 return val;
2546 }
2547
2548 return value_assign (toval, fromval);
2549}
2550
2551
52ce6436
PH
2552/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2553 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2554 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2555 * COMPONENT, and not the inferior's memory. The current contents
2556 * of COMPONENT are ignored. */
2557static void
2558value_assign_to_component (struct value *container, struct value *component,
2559 struct value *val)
2560{
2561 LONGEST offset_in_container =
42ae5230 2562 (LONGEST) (value_address (component) - value_address (container));
52ce6436
PH
2563 int bit_offset_in_container =
2564 value_bitpos (component) - value_bitpos (container);
2565 int bits;
2566
2567 val = value_cast (value_type (component), val);
2568
2569 if (value_bitsize (component) == 0)
2570 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2571 else
2572 bits = value_bitsize (component);
2573
50810684 2574 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
52ce6436
PH
2575 move_bits (value_contents_writeable (container) + offset_in_container,
2576 value_bitpos (container) + bit_offset_in_container,
2577 value_contents (val),
2578 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
50810684 2579 bits, 1);
52ce6436
PH
2580 else
2581 move_bits (value_contents_writeable (container) + offset_in_container,
2582 value_bitpos (container) + bit_offset_in_container,
50810684 2583 value_contents (val), 0, bits, 0);
52ce6436
PH
2584}
2585
4c4b4cd2
PH
2586/* The value of the element of array ARR at the ARITY indices given in IND.
2587 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2588 thereto. */
2589
d2e4a39e
AS
2590struct value *
2591ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2592{
2593 int k;
d2e4a39e
AS
2594 struct value *elt;
2595 struct type *elt_type;
14f9c5c9
AS
2596
2597 elt = ada_coerce_to_simple_array (arr);
2598
df407dfe 2599 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2600 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2601 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2602 return value_subscript_packed (elt, arity, ind);
2603
2604 for (k = 0; k < arity; k += 1)
2605 {
2606 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2607 error (_("too many subscripts (%d expected)"), k);
2497b498 2608 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2609 }
2610 return elt;
2611}
2612
2613/* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2614 value of the element of *ARR at the ARITY indices given in
4c4b4cd2 2615 IND. Does not read the entire array into memory. */
14f9c5c9 2616
2c0b251b 2617static struct value *
d2e4a39e 2618ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
4c4b4cd2 2619 struct value **ind)
14f9c5c9
AS
2620{
2621 int k;
2622
2623 for (k = 0; k < arity; k += 1)
2624 {
2625 LONGEST lwb, upb;
14f9c5c9
AS
2626
2627 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2628 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2629 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2630 value_copy (arr));
14f9c5c9 2631 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2497b498 2632 arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
14f9c5c9
AS
2633 type = TYPE_TARGET_TYPE (type);
2634 }
2635
2636 return value_ind (arr);
2637}
2638
0b5d8877 2639/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
f5938064
JG
2640 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2641 elements starting at index LOW. The lower bound of this array is LOW, as
0963b4bd 2642 per Ada rules. */
0b5d8877 2643static struct value *
f5938064
JG
2644ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2645 int low, int high)
0b5d8877 2646{
b0dd7688 2647 struct type *type0 = ada_check_typedef (type);
6c038f32 2648 CORE_ADDR base = value_as_address (array_ptr)
b0dd7688
JB
2649 + ((low - ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0)))
2650 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
6c038f32 2651 struct type *index_type =
b0dd7688 2652 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)),
0b5d8877 2653 low, high);
6c038f32 2654 struct type *slice_type =
b0dd7688 2655 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
5b4ee69b 2656
f5938064 2657 return value_at_lazy (slice_type, base);
0b5d8877
PH
2658}
2659
2660
2661static struct value *
2662ada_value_slice (struct value *array, int low, int high)
2663{
b0dd7688 2664 struct type *type = ada_check_typedef (value_type (array));
6c038f32 2665 struct type *index_type =
0b5d8877 2666 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
6c038f32 2667 struct type *slice_type =
0b5d8877 2668 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
5b4ee69b 2669
6c038f32 2670 return value_cast (slice_type, value_slice (array, low, high - low + 1));
0b5d8877
PH
2671}
2672
14f9c5c9
AS
2673/* If type is a record type in the form of a standard GNAT array
2674 descriptor, returns the number of dimensions for type. If arr is a
2675 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2676 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2677
2678int
d2e4a39e 2679ada_array_arity (struct type *type)
14f9c5c9
AS
2680{
2681 int arity;
2682
2683 if (type == NULL)
2684 return 0;
2685
2686 type = desc_base_type (type);
2687
2688 arity = 0;
d2e4a39e 2689 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2690 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2691 else
2692 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2693 {
4c4b4cd2 2694 arity += 1;
61ee279c 2695 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2696 }
d2e4a39e 2697
14f9c5c9
AS
2698 return arity;
2699}
2700
2701/* If TYPE is a record type in the form of a standard GNAT array
2702 descriptor or a simple array type, returns the element type for
2703 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2704 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2705
d2e4a39e
AS
2706struct type *
2707ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2708{
2709 type = desc_base_type (type);
2710
d2e4a39e 2711 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2712 {
2713 int k;
d2e4a39e 2714 struct type *p_array_type;
14f9c5c9 2715
556bdfd4 2716 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
2717
2718 k = ada_array_arity (type);
2719 if (k == 0)
4c4b4cd2 2720 return NULL;
d2e4a39e 2721
4c4b4cd2 2722 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2723 if (nindices >= 0 && k > nindices)
4c4b4cd2 2724 k = nindices;
d2e4a39e 2725 while (k > 0 && p_array_type != NULL)
4c4b4cd2 2726 {
61ee279c 2727 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
2728 k -= 1;
2729 }
14f9c5c9
AS
2730 return p_array_type;
2731 }
2732 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2733 {
2734 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
2735 {
2736 type = TYPE_TARGET_TYPE (type);
2737 nindices -= 1;
2738 }
14f9c5c9
AS
2739 return type;
2740 }
2741
2742 return NULL;
2743}
2744
4c4b4cd2 2745/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
2746 Does not examine memory. Throws an error if N is invalid or TYPE
2747 is not an array type. NAME is the name of the Ada attribute being
2748 evaluated ('range, 'first, 'last, or 'length); it is used in building
2749 the error message. */
14f9c5c9 2750
1eea4ebd
UW
2751static struct type *
2752ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 2753{
4c4b4cd2
PH
2754 struct type *result_type;
2755
14f9c5c9
AS
2756 type = desc_base_type (type);
2757
1eea4ebd
UW
2758 if (n < 0 || n > ada_array_arity (type))
2759 error (_("invalid dimension number to '%s"), name);
14f9c5c9 2760
4c4b4cd2 2761 if (ada_is_simple_array_type (type))
14f9c5c9
AS
2762 {
2763 int i;
2764
2765 for (i = 1; i < n; i += 1)
4c4b4cd2 2766 type = TYPE_TARGET_TYPE (type);
262452ec 2767 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
2768 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2769 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 2770 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
2771 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2772 result_type = NULL;
14f9c5c9 2773 }
d2e4a39e 2774 else
1eea4ebd
UW
2775 {
2776 result_type = desc_index_type (desc_bounds_type (type), n);
2777 if (result_type == NULL)
2778 error (_("attempt to take bound of something that is not an array"));
2779 }
2780
2781 return result_type;
14f9c5c9
AS
2782}
2783
2784/* Given that arr is an array type, returns the lower bound of the
2785 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 2786 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
2787 array-descriptor type. It works for other arrays with bounds supplied
2788 by run-time quantities other than discriminants. */
14f9c5c9 2789
abb68b3e 2790static LONGEST
1eea4ebd 2791ada_array_bound_from_type (struct type * arr_type, int n, int which)
14f9c5c9 2792{
1ce677a4 2793 struct type *type, *elt_type, *index_type_desc, *index_type;
1ce677a4 2794 int i;
262452ec
JK
2795
2796 gdb_assert (which == 0 || which == 1);
14f9c5c9 2797
ad82864c
JB
2798 if (ada_is_constrained_packed_array_type (arr_type))
2799 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 2800
4c4b4cd2 2801 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 2802 return (LONGEST) - which;
14f9c5c9
AS
2803
2804 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2805 type = TYPE_TARGET_TYPE (arr_type);
2806 else
2807 type = arr_type;
2808
1ce677a4
UW
2809 elt_type = type;
2810 for (i = n; i > 1; i--)
2811 elt_type = TYPE_TARGET_TYPE (type);
2812
14f9c5c9 2813 index_type_desc = ada_find_parallel_type (type, "___XA");
28c85d6c 2814 ada_fixup_array_indexes_type (index_type_desc);
262452ec 2815 if (index_type_desc != NULL)
28c85d6c
JB
2816 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
2817 NULL);
262452ec 2818 else
1ce677a4 2819 index_type = TYPE_INDEX_TYPE (elt_type);
262452ec 2820
43bbcdc2
PH
2821 return
2822 (LONGEST) (which == 0
2823 ? ada_discrete_type_low_bound (index_type)
2824 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
2825}
2826
2827/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
2828 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2829 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 2830 supplied by run-time quantities other than discriminants. */
14f9c5c9 2831
1eea4ebd 2832static LONGEST
4dc81987 2833ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 2834{
df407dfe 2835 struct type *arr_type = value_type (arr);
14f9c5c9 2836
ad82864c
JB
2837 if (ada_is_constrained_packed_array_type (arr_type))
2838 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 2839 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 2840 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 2841 else
1eea4ebd 2842 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
2843}
2844
2845/* Given that arr is an array value, returns the length of the
2846 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
2847 supplied by run-time quantities other than discriminants.
2848 Does not work for arrays indexed by enumeration types with representation
2849 clauses at the moment. */
14f9c5c9 2850
1eea4ebd 2851static LONGEST
d2e4a39e 2852ada_array_length (struct value *arr, int n)
14f9c5c9 2853{
df407dfe 2854 struct type *arr_type = ada_check_typedef (value_type (arr));
14f9c5c9 2855
ad82864c
JB
2856 if (ada_is_constrained_packed_array_type (arr_type))
2857 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 2858
4c4b4cd2 2859 if (ada_is_simple_array_type (arr_type))
1eea4ebd
UW
2860 return (ada_array_bound_from_type (arr_type, n, 1)
2861 - ada_array_bound_from_type (arr_type, n, 0) + 1);
14f9c5c9 2862 else
1eea4ebd
UW
2863 return (value_as_long (desc_one_bound (desc_bounds (arr), n, 1))
2864 - value_as_long (desc_one_bound (desc_bounds (arr), n, 0)) + 1);
4c4b4cd2
PH
2865}
2866
2867/* An empty array whose type is that of ARR_TYPE (an array type),
2868 with bounds LOW to LOW-1. */
2869
2870static struct value *
2871empty_array (struct type *arr_type, int low)
2872{
b0dd7688 2873 struct type *arr_type0 = ada_check_typedef (arr_type);
6c038f32 2874 struct type *index_type =
b0dd7688 2875 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)),
0b5d8877 2876 low, low - 1);
b0dd7688 2877 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 2878
0b5d8877 2879 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 2880}
14f9c5c9 2881\f
d2e4a39e 2882
4c4b4cd2 2883 /* Name resolution */
14f9c5c9 2884
4c4b4cd2
PH
2885/* The "decoded" name for the user-definable Ada operator corresponding
2886 to OP. */
14f9c5c9 2887
d2e4a39e 2888static const char *
4c4b4cd2 2889ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
2890{
2891 int i;
2892
4c4b4cd2 2893 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
2894 {
2895 if (ada_opname_table[i].op == op)
4c4b4cd2 2896 return ada_opname_table[i].decoded;
14f9c5c9 2897 }
323e0a4a 2898 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
2899}
2900
2901
4c4b4cd2
PH
2902/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2903 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2904 undefined namespace) and converts operators that are
2905 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
2906 non-null, it provides a preferred result type [at the moment, only
2907 type void has any effect---causing procedures to be preferred over
2908 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 2909 return type is preferred. May change (expand) *EXP. */
14f9c5c9 2910
4c4b4cd2
PH
2911static void
2912resolve (struct expression **expp, int void_context_p)
14f9c5c9 2913{
30b15541
UW
2914 struct type *context_type = NULL;
2915 int pc = 0;
2916
2917 if (void_context_p)
2918 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
2919
2920 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
2921}
2922
4c4b4cd2
PH
2923/* Resolve the operator of the subexpression beginning at
2924 position *POS of *EXPP. "Resolving" consists of replacing
2925 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2926 with their resolutions, replacing built-in operators with
2927 function calls to user-defined operators, where appropriate, and,
2928 when DEPROCEDURE_P is non-zero, converting function-valued variables
2929 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2930 are as in ada_resolve, above. */
14f9c5c9 2931
d2e4a39e 2932static struct value *
4c4b4cd2 2933resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
76a01679 2934 struct type *context_type)
14f9c5c9
AS
2935{
2936 int pc = *pos;
2937 int i;
4c4b4cd2 2938 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 2939 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
2940 struct value **argvec; /* Vector of operand types (alloca'ed). */
2941 int nargs; /* Number of operands. */
52ce6436 2942 int oplen;
14f9c5c9
AS
2943
2944 argvec = NULL;
2945 nargs = 0;
2946 exp = *expp;
2947
52ce6436
PH
2948 /* Pass one: resolve operands, saving their types and updating *pos,
2949 if needed. */
14f9c5c9
AS
2950 switch (op)
2951 {
4c4b4cd2
PH
2952 case OP_FUNCALL:
2953 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
2954 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2955 *pos += 7;
4c4b4cd2
PH
2956 else
2957 {
2958 *pos += 3;
2959 resolve_subexp (expp, pos, 0, NULL);
2960 }
2961 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
2962 break;
2963
14f9c5c9 2964 case UNOP_ADDR:
4c4b4cd2
PH
2965 *pos += 1;
2966 resolve_subexp (expp, pos, 0, NULL);
2967 break;
2968
52ce6436
PH
2969 case UNOP_QUAL:
2970 *pos += 3;
17466c1a 2971 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
2972 break;
2973
52ce6436 2974 case OP_ATR_MODULUS:
4c4b4cd2
PH
2975 case OP_ATR_SIZE:
2976 case OP_ATR_TAG:
4c4b4cd2
PH
2977 case OP_ATR_FIRST:
2978 case OP_ATR_LAST:
2979 case OP_ATR_LENGTH:
2980 case OP_ATR_POS:
2981 case OP_ATR_VAL:
4c4b4cd2
PH
2982 case OP_ATR_MIN:
2983 case OP_ATR_MAX:
52ce6436
PH
2984 case TERNOP_IN_RANGE:
2985 case BINOP_IN_BOUNDS:
2986 case UNOP_IN_RANGE:
2987 case OP_AGGREGATE:
2988 case OP_OTHERS:
2989 case OP_CHOICES:
2990 case OP_POSITIONAL:
2991 case OP_DISCRETE_RANGE:
2992 case OP_NAME:
2993 ada_forward_operator_length (exp, pc, &oplen, &nargs);
2994 *pos += oplen;
14f9c5c9
AS
2995 break;
2996
2997 case BINOP_ASSIGN:
2998 {
4c4b4cd2
PH
2999 struct value *arg1;
3000
3001 *pos += 1;
3002 arg1 = resolve_subexp (expp, pos, 0, NULL);
3003 if (arg1 == NULL)
3004 resolve_subexp (expp, pos, 1, NULL);
3005 else
df407dfe 3006 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 3007 break;
14f9c5c9
AS
3008 }
3009
4c4b4cd2 3010 case UNOP_CAST:
4c4b4cd2
PH
3011 *pos += 3;
3012 nargs = 1;
3013 break;
14f9c5c9 3014
4c4b4cd2
PH
3015 case BINOP_ADD:
3016 case BINOP_SUB:
3017 case BINOP_MUL:
3018 case BINOP_DIV:
3019 case BINOP_REM:
3020 case BINOP_MOD:
3021 case BINOP_EXP:
3022 case BINOP_CONCAT:
3023 case BINOP_LOGICAL_AND:
3024 case BINOP_LOGICAL_OR:
3025 case BINOP_BITWISE_AND:
3026 case BINOP_BITWISE_IOR:
3027 case BINOP_BITWISE_XOR:
14f9c5c9 3028
4c4b4cd2
PH
3029 case BINOP_EQUAL:
3030 case BINOP_NOTEQUAL:
3031 case BINOP_LESS:
3032 case BINOP_GTR:
3033 case BINOP_LEQ:
3034 case BINOP_GEQ:
14f9c5c9 3035
4c4b4cd2
PH
3036 case BINOP_REPEAT:
3037 case BINOP_SUBSCRIPT:
3038 case BINOP_COMMA:
40c8aaa9
JB
3039 *pos += 1;
3040 nargs = 2;
3041 break;
14f9c5c9 3042
4c4b4cd2
PH
3043 case UNOP_NEG:
3044 case UNOP_PLUS:
3045 case UNOP_LOGICAL_NOT:
3046 case UNOP_ABS:
3047 case UNOP_IND:
3048 *pos += 1;
3049 nargs = 1;
3050 break;
14f9c5c9 3051
4c4b4cd2
PH
3052 case OP_LONG:
3053 case OP_DOUBLE:
3054 case OP_VAR_VALUE:
3055 *pos += 4;
3056 break;
14f9c5c9 3057
4c4b4cd2
PH
3058 case OP_TYPE:
3059 case OP_BOOL:
3060 case OP_LAST:
4c4b4cd2
PH
3061 case OP_INTERNALVAR:
3062 *pos += 3;
3063 break;
14f9c5c9 3064
4c4b4cd2
PH
3065 case UNOP_MEMVAL:
3066 *pos += 3;
3067 nargs = 1;
3068 break;
3069
67f3407f
DJ
3070 case OP_REGISTER:
3071 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3072 break;
3073
4c4b4cd2
PH
3074 case STRUCTOP_STRUCT:
3075 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3076 nargs = 1;
3077 break;
3078
4c4b4cd2 3079 case TERNOP_SLICE:
4c4b4cd2
PH
3080 *pos += 1;
3081 nargs = 3;
3082 break;
3083
52ce6436 3084 case OP_STRING:
14f9c5c9 3085 break;
4c4b4cd2
PH
3086
3087 default:
323e0a4a 3088 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3089 }
3090
76a01679 3091 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
4c4b4cd2
PH
3092 for (i = 0; i < nargs; i += 1)
3093 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3094 argvec[i] = NULL;
3095 exp = *expp;
3096
3097 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3098 switch (op)
3099 {
3100 default:
3101 break;
3102
14f9c5c9 3103 case OP_VAR_VALUE:
4c4b4cd2 3104 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
3105 {
3106 struct ada_symbol_info *candidates;
3107 int n_candidates;
3108
3109 n_candidates =
3110 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3111 (exp->elts[pc + 2].symbol),
3112 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3113 &candidates);
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,
4eeaa230 3205 &candidates);
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,
4eeaa230 3257 &candidates);
4c4b4cd2 3258 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
76a01679 3259 ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3260 if (i < 0)
3261 break;
3262
76a01679
JB
3263 replace_operator_with_call (expp, pc, nargs, 1,
3264 candidates[i].sym, candidates[i].block);
4c4b4cd2
PH
3265 exp = *expp;
3266 }
14f9c5c9 3267 break;
4c4b4cd2
PH
3268
3269 case OP_TYPE:
b3dbf008 3270 case OP_REGISTER:
4c4b4cd2 3271 return NULL;
14f9c5c9
AS
3272 }
3273
3274 *pos = pc;
3275 return evaluate_subexp_type (exp, pos);
3276}
3277
3278/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3279 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3280 a non-pointer. */
14f9c5c9 3281/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3282 liberal. */
14f9c5c9
AS
3283
3284static int
4dc81987 3285ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3286{
61ee279c
PH
3287 ftype = ada_check_typedef (ftype);
3288 atype = ada_check_typedef (atype);
14f9c5c9
AS
3289
3290 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3291 ftype = TYPE_TARGET_TYPE (ftype);
3292 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3293 atype = TYPE_TARGET_TYPE (atype);
3294
d2e4a39e 3295 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3296 {
3297 default:
5b3d5b7d 3298 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3299 case TYPE_CODE_PTR:
3300 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3301 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3302 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3303 else
1265e4aa
JB
3304 return (may_deref
3305 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3306 case TYPE_CODE_INT:
3307 case TYPE_CODE_ENUM:
3308 case TYPE_CODE_RANGE:
3309 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3310 {
3311 case TYPE_CODE_INT:
3312 case TYPE_CODE_ENUM:
3313 case TYPE_CODE_RANGE:
3314 return 1;
3315 default:
3316 return 0;
3317 }
14f9c5c9
AS
3318
3319 case TYPE_CODE_ARRAY:
d2e4a39e 3320 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3321 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3322
3323 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3324 if (ada_is_array_descriptor_type (ftype))
3325 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3326 || ada_is_array_descriptor_type (atype));
14f9c5c9 3327 else
4c4b4cd2
PH
3328 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3329 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3330
3331 case TYPE_CODE_UNION:
3332 case TYPE_CODE_FLT:
3333 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3334 }
3335}
3336
3337/* Return non-zero if the formals of FUNC "sufficiently match" the
3338 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3339 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3340 argument function. */
14f9c5c9
AS
3341
3342static int
d2e4a39e 3343ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3344{
3345 int i;
d2e4a39e 3346 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3347
1265e4aa
JB
3348 if (SYMBOL_CLASS (func) == LOC_CONST
3349 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3350 return (n_actuals == 0);
3351 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3352 return 0;
3353
3354 if (TYPE_NFIELDS (func_type) != n_actuals)
3355 return 0;
3356
3357 for (i = 0; i < n_actuals; i += 1)
3358 {
4c4b4cd2 3359 if (actuals[i] == NULL)
76a01679
JB
3360 return 0;
3361 else
3362 {
5b4ee69b
MS
3363 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3364 i));
df407dfe 3365 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3366
76a01679
JB
3367 if (!ada_type_match (ftype, atype, 1))
3368 return 0;
3369 }
14f9c5c9
AS
3370 }
3371 return 1;
3372}
3373
3374/* False iff function type FUNC_TYPE definitely does not produce a value
3375 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3376 FUNC_TYPE is not a valid function type with a non-null return type
3377 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3378
3379static int
d2e4a39e 3380return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3381{
d2e4a39e 3382 struct type *return_type;
14f9c5c9
AS
3383
3384 if (func_type == NULL)
3385 return 1;
3386
4c4b4cd2 3387 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3388 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3389 else
18af8284 3390 return_type = get_base_type (func_type);
14f9c5c9
AS
3391 if (return_type == NULL)
3392 return 1;
3393
18af8284 3394 context_type = get_base_type (context_type);
14f9c5c9
AS
3395
3396 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3397 return context_type == NULL || return_type == context_type;
3398 else if (context_type == NULL)
3399 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3400 else
3401 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3402}
3403
3404
4c4b4cd2 3405/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3406 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3407 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3408 that returns that type, then eliminate matches that don't. If
3409 CONTEXT_TYPE is void and there is at least one match that does not
3410 return void, eliminate all matches that do.
3411
14f9c5c9
AS
3412 Asks the user if there is more than one match remaining. Returns -1
3413 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3414 solely for messages. May re-arrange and modify SYMS in
3415 the process; the index returned is for the modified vector. */
14f9c5c9 3416
4c4b4cd2
PH
3417static int
3418ada_resolve_function (struct ada_symbol_info syms[],
3419 int nsyms, struct value **args, int nargs,
3420 const char *name, struct type *context_type)
14f9c5c9 3421{
30b15541 3422 int fallback;
14f9c5c9 3423 int k;
4c4b4cd2 3424 int m; /* Number of hits */
14f9c5c9 3425
d2e4a39e 3426 m = 0;
30b15541
UW
3427 /* In the first pass of the loop, we only accept functions matching
3428 context_type. If none are found, we add a second pass of the loop
3429 where every function is accepted. */
3430 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3431 {
3432 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3433 {
61ee279c 3434 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
4c4b4cd2
PH
3435
3436 if (ada_args_match (syms[k].sym, args, nargs)
30b15541 3437 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3438 {
3439 syms[m] = syms[k];
3440 m += 1;
3441 }
3442 }
14f9c5c9
AS
3443 }
3444
3445 if (m == 0)
3446 return -1;
3447 else if (m > 1)
3448 {
323e0a4a 3449 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3450 user_select_syms (syms, m, 1);
14f9c5c9
AS
3451 return 0;
3452 }
3453 return 0;
3454}
3455
4c4b4cd2
PH
3456/* Returns true (non-zero) iff decoded name N0 should appear before N1
3457 in a listing of choices during disambiguation (see sort_choices, below).
3458 The idea is that overloadings of a subprogram name from the
3459 same package should sort in their source order. We settle for ordering
3460 such symbols by their trailing number (__N or $N). */
3461
14f9c5c9 3462static int
0d5cff50 3463encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3464{
3465 if (N1 == NULL)
3466 return 0;
3467 else if (N0 == NULL)
3468 return 1;
3469 else
3470 {
3471 int k0, k1;
5b4ee69b 3472
d2e4a39e 3473 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3474 ;
d2e4a39e 3475 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3476 ;
d2e4a39e 3477 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3478 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3479 {
3480 int n0, n1;
5b4ee69b 3481
4c4b4cd2
PH
3482 n0 = k0;
3483 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3484 n0 -= 1;
3485 n1 = k1;
3486 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3487 n1 -= 1;
3488 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3489 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3490 }
14f9c5c9
AS
3491 return (strcmp (N0, N1) < 0);
3492 }
3493}
d2e4a39e 3494
4c4b4cd2
PH
3495/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3496 encoded names. */
3497
d2e4a39e 3498static void
4c4b4cd2 3499sort_choices (struct ada_symbol_info syms[], int nsyms)
14f9c5c9 3500{
4c4b4cd2 3501 int i;
5b4ee69b 3502
d2e4a39e 3503 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3504 {
4c4b4cd2 3505 struct ada_symbol_info sym = syms[i];
14f9c5c9
AS
3506 int j;
3507
d2e4a39e 3508 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2
PH
3509 {
3510 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3511 SYMBOL_LINKAGE_NAME (sym.sym)))
3512 break;
3513 syms[j + 1] = syms[j];
3514 }
d2e4a39e 3515 syms[j + 1] = sym;
14f9c5c9
AS
3516 }
3517}
3518
4c4b4cd2
PH
3519/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3520 by asking the user (if necessary), returning the number selected,
3521 and setting the first elements of SYMS items. Error if no symbols
3522 selected. */
14f9c5c9
AS
3523
3524/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3525 to be re-integrated one of these days. */
14f9c5c9
AS
3526
3527int
4c4b4cd2 3528user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
14f9c5c9
AS
3529{
3530 int i;
d2e4a39e 3531 int *chosen = (int *) alloca (sizeof (int) * nsyms);
14f9c5c9
AS
3532 int n_chosen;
3533 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3534 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3535
3536 if (max_results < 1)
323e0a4a 3537 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3538 if (nsyms <= 1)
3539 return nsyms;
3540
717d2f5a
JB
3541 if (select_mode == multiple_symbols_cancel)
3542 error (_("\
3543canceled because the command is ambiguous\n\
3544See set/show multiple-symbol."));
3545
3546 /* If select_mode is "all", then return all possible symbols.
3547 Only do that if more than one symbol can be selected, of course.
3548 Otherwise, display the menu as usual. */
3549 if (select_mode == multiple_symbols_all && max_results > 1)
3550 return nsyms;
3551
323e0a4a 3552 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3553 if (max_results > 1)
323e0a4a 3554 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3555
4c4b4cd2 3556 sort_choices (syms, nsyms);
14f9c5c9
AS
3557
3558 for (i = 0; i < nsyms; i += 1)
3559 {
4c4b4cd2
PH
3560 if (syms[i].sym == NULL)
3561 continue;
3562
3563 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3564 {
76a01679
JB
3565 struct symtab_and_line sal =
3566 find_function_start_sal (syms[i].sym, 1);
5b4ee69b 3567
323e0a4a
AC
3568 if (sal.symtab == NULL)
3569 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3570 i + first_choice,
3571 SYMBOL_PRINT_NAME (syms[i].sym),
3572 sal.line);
3573 else
3574 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3575 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821
JK
3576 symtab_to_filename_for_display (sal.symtab),
3577 sal.line);
4c4b4cd2
PH
3578 continue;
3579 }
d2e4a39e 3580 else
4c4b4cd2
PH
3581 {
3582 int is_enumeral =
3583 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3584 && SYMBOL_TYPE (syms[i].sym) != NULL
3585 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
210bbc17 3586 struct symtab *symtab = SYMBOL_SYMTAB (syms[i].sym);
4c4b4cd2
PH
3587
3588 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
323e0a4a 3589 printf_unfiltered (_("[%d] %s at %s:%d\n"),
4c4b4cd2
PH
3590 i + first_choice,
3591 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821
JK
3592 symtab_to_filename_for_display (symtab),
3593 SYMBOL_LINE (syms[i].sym));
76a01679
JB
3594 else if (is_enumeral
3595 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
4c4b4cd2 3596 {
a3f17187 3597 printf_unfiltered (("[%d] "), i + first_choice);
76a01679 3598 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
79d43c61 3599 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3600 printf_unfiltered (_("'(%s) (enumeral)\n"),
4c4b4cd2
PH
3601 SYMBOL_PRINT_NAME (syms[i].sym));
3602 }
3603 else if (symtab != NULL)
3604 printf_unfiltered (is_enumeral
323e0a4a
AC
3605 ? _("[%d] %s in %s (enumeral)\n")
3606 : _("[%d] %s at %s:?\n"),
4c4b4cd2
PH
3607 i + first_choice,
3608 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821 3609 symtab_to_filename_for_display (symtab));
4c4b4cd2
PH
3610 else
3611 printf_unfiltered (is_enumeral
323e0a4a
AC
3612 ? _("[%d] %s (enumeral)\n")
3613 : _("[%d] %s at ?\n"),
4c4b4cd2
PH
3614 i + first_choice,
3615 SYMBOL_PRINT_NAME (syms[i].sym));
3616 }
14f9c5c9 3617 }
d2e4a39e 3618
14f9c5c9 3619 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 3620 "overload-choice");
14f9c5c9
AS
3621
3622 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 3623 syms[i] = syms[chosen[i]];
14f9c5c9
AS
3624
3625 return n_chosen;
3626}
3627
3628/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 3629 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
3630 order in CHOICES[0 .. N-1], and return N.
3631
3632 The user types choices as a sequence of numbers on one line
3633 separated by blanks, encoding them as follows:
3634
4c4b4cd2 3635 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
3636 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3637 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3638
4c4b4cd2 3639 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
3640
3641 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 3642 prompts (for use with the -f switch). */
14f9c5c9
AS
3643
3644int
d2e4a39e 3645get_selections (int *choices, int n_choices, int max_results,
4c4b4cd2 3646 int is_all_choice, char *annotation_suffix)
14f9c5c9 3647{
d2e4a39e 3648 char *args;
0bcd0149 3649 char *prompt;
14f9c5c9
AS
3650 int n_chosen;
3651 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 3652
14f9c5c9
AS
3653 prompt = getenv ("PS2");
3654 if (prompt == NULL)
0bcd0149 3655 prompt = "> ";
14f9c5c9 3656
0bcd0149 3657 args = command_line_input (prompt, 0, annotation_suffix);
d2e4a39e 3658
14f9c5c9 3659 if (args == NULL)
323e0a4a 3660 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
3661
3662 n_chosen = 0;
76a01679 3663
4c4b4cd2
PH
3664 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3665 order, as given in args. Choices are validated. */
14f9c5c9
AS
3666 while (1)
3667 {
d2e4a39e 3668 char *args2;
14f9c5c9
AS
3669 int choice, j;
3670
0fcd72ba 3671 args = skip_spaces (args);
14f9c5c9 3672 if (*args == '\0' && n_chosen == 0)
323e0a4a 3673 error_no_arg (_("one or more choice numbers"));
14f9c5c9 3674 else if (*args == '\0')
4c4b4cd2 3675 break;
14f9c5c9
AS
3676
3677 choice = strtol (args, &args2, 10);
d2e4a39e 3678 if (args == args2 || choice < 0
4c4b4cd2 3679 || choice > n_choices + first_choice - 1)
323e0a4a 3680 error (_("Argument must be choice number"));
14f9c5c9
AS
3681 args = args2;
3682
d2e4a39e 3683 if (choice == 0)
323e0a4a 3684 error (_("cancelled"));
14f9c5c9
AS
3685
3686 if (choice < first_choice)
4c4b4cd2
PH
3687 {
3688 n_chosen = n_choices;
3689 for (j = 0; j < n_choices; j += 1)
3690 choices[j] = j;
3691 break;
3692 }
14f9c5c9
AS
3693 choice -= first_choice;
3694
d2e4a39e 3695 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
3696 {
3697 }
14f9c5c9
AS
3698
3699 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
3700 {
3701 int k;
5b4ee69b 3702
4c4b4cd2
PH
3703 for (k = n_chosen - 1; k > j; k -= 1)
3704 choices[k + 1] = choices[k];
3705 choices[j + 1] = choice;
3706 n_chosen += 1;
3707 }
14f9c5c9
AS
3708 }
3709
3710 if (n_chosen > max_results)
323e0a4a 3711 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 3712
14f9c5c9
AS
3713 return n_chosen;
3714}
3715
4c4b4cd2
PH
3716/* Replace the operator of length OPLEN at position PC in *EXPP with a call
3717 on the function identified by SYM and BLOCK, and taking NARGS
3718 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
3719
3720static void
d2e4a39e 3721replace_operator_with_call (struct expression **expp, int pc, int nargs,
4c4b4cd2 3722 int oplen, struct symbol *sym,
270140bd 3723 const struct block *block)
14f9c5c9
AS
3724{
3725 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 3726 symbol, -oplen for operator being replaced). */
d2e4a39e 3727 struct expression *newexp = (struct expression *)
8c1a34e7 3728 xzalloc (sizeof (struct expression)
4c4b4cd2 3729 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
d2e4a39e 3730 struct expression *exp = *expp;
14f9c5c9
AS
3731
3732 newexp->nelts = exp->nelts + 7 - oplen;
3733 newexp->language_defn = exp->language_defn;
3489610d 3734 newexp->gdbarch = exp->gdbarch;
14f9c5c9 3735 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 3736 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 3737 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
3738
3739 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3740 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3741
3742 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3743 newexp->elts[pc + 4].block = block;
3744 newexp->elts[pc + 5].symbol = sym;
3745
3746 *expp = newexp;
aacb1f0a 3747 xfree (exp);
d2e4a39e 3748}
14f9c5c9
AS
3749
3750/* Type-class predicates */
3751
4c4b4cd2
PH
3752/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3753 or FLOAT). */
14f9c5c9
AS
3754
3755static int
d2e4a39e 3756numeric_type_p (struct type *type)
14f9c5c9
AS
3757{
3758 if (type == NULL)
3759 return 0;
d2e4a39e
AS
3760 else
3761 {
3762 switch (TYPE_CODE (type))
4c4b4cd2
PH
3763 {
3764 case TYPE_CODE_INT:
3765 case TYPE_CODE_FLT:
3766 return 1;
3767 case TYPE_CODE_RANGE:
3768 return (type == TYPE_TARGET_TYPE (type)
3769 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3770 default:
3771 return 0;
3772 }
d2e4a39e 3773 }
14f9c5c9
AS
3774}
3775
4c4b4cd2 3776/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
3777
3778static int
d2e4a39e 3779integer_type_p (struct type *type)
14f9c5c9
AS
3780{
3781 if (type == NULL)
3782 return 0;
d2e4a39e
AS
3783 else
3784 {
3785 switch (TYPE_CODE (type))
4c4b4cd2
PH
3786 {
3787 case TYPE_CODE_INT:
3788 return 1;
3789 case TYPE_CODE_RANGE:
3790 return (type == TYPE_TARGET_TYPE (type)
3791 || integer_type_p (TYPE_TARGET_TYPE (type)));
3792 default:
3793 return 0;
3794 }
d2e4a39e 3795 }
14f9c5c9
AS
3796}
3797
4c4b4cd2 3798/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
3799
3800static int
d2e4a39e 3801scalar_type_p (struct type *type)
14f9c5c9
AS
3802{
3803 if (type == NULL)
3804 return 0;
d2e4a39e
AS
3805 else
3806 {
3807 switch (TYPE_CODE (type))
4c4b4cd2
PH
3808 {
3809 case TYPE_CODE_INT:
3810 case TYPE_CODE_RANGE:
3811 case TYPE_CODE_ENUM:
3812 case TYPE_CODE_FLT:
3813 return 1;
3814 default:
3815 return 0;
3816 }
d2e4a39e 3817 }
14f9c5c9
AS
3818}
3819
4c4b4cd2 3820/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
3821
3822static int
d2e4a39e 3823discrete_type_p (struct type *type)
14f9c5c9
AS
3824{
3825 if (type == NULL)
3826 return 0;
d2e4a39e
AS
3827 else
3828 {
3829 switch (TYPE_CODE (type))
4c4b4cd2
PH
3830 {
3831 case TYPE_CODE_INT:
3832 case TYPE_CODE_RANGE:
3833 case TYPE_CODE_ENUM:
872f0337 3834 case TYPE_CODE_BOOL:
4c4b4cd2
PH
3835 return 1;
3836 default:
3837 return 0;
3838 }
d2e4a39e 3839 }
14f9c5c9
AS
3840}
3841
4c4b4cd2
PH
3842/* Returns non-zero if OP with operands in the vector ARGS could be
3843 a user-defined function. Errs on the side of pre-defined operators
3844 (i.e., result 0). */
14f9c5c9
AS
3845
3846static int
d2e4a39e 3847possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 3848{
76a01679 3849 struct type *type0 =
df407dfe 3850 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 3851 struct type *type1 =
df407dfe 3852 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 3853
4c4b4cd2
PH
3854 if (type0 == NULL)
3855 return 0;
3856
14f9c5c9
AS
3857 switch (op)
3858 {
3859 default:
3860 return 0;
3861
3862 case BINOP_ADD:
3863 case BINOP_SUB:
3864 case BINOP_MUL:
3865 case BINOP_DIV:
d2e4a39e 3866 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
3867
3868 case BINOP_REM:
3869 case BINOP_MOD:
3870 case BINOP_BITWISE_AND:
3871 case BINOP_BITWISE_IOR:
3872 case BINOP_BITWISE_XOR:
d2e4a39e 3873 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3874
3875 case BINOP_EQUAL:
3876 case BINOP_NOTEQUAL:
3877 case BINOP_LESS:
3878 case BINOP_GTR:
3879 case BINOP_LEQ:
3880 case BINOP_GEQ:
d2e4a39e 3881 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
3882
3883 case BINOP_CONCAT:
ee90b9ab 3884 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
3885
3886 case BINOP_EXP:
d2e4a39e 3887 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3888
3889 case UNOP_NEG:
3890 case UNOP_PLUS:
3891 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
3892 case UNOP_ABS:
3893 return (!numeric_type_p (type0));
14f9c5c9
AS
3894
3895 }
3896}
3897\f
4c4b4cd2 3898 /* Renaming */
14f9c5c9 3899
aeb5907d
JB
3900/* NOTES:
3901
3902 1. In the following, we assume that a renaming type's name may
3903 have an ___XD suffix. It would be nice if this went away at some
3904 point.
3905 2. We handle both the (old) purely type-based representation of
3906 renamings and the (new) variable-based encoding. At some point,
3907 it is devoutly to be hoped that the former goes away
3908 (FIXME: hilfinger-2007-07-09).
3909 3. Subprogram renamings are not implemented, although the XRS
3910 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3911
3912/* If SYM encodes a renaming,
3913
3914 <renaming> renames <renamed entity>,
3915
3916 sets *LEN to the length of the renamed entity's name,
3917 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3918 the string describing the subcomponent selected from the renamed
0963b4bd 3919 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
3920 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3921 are undefined). Otherwise, returns a value indicating the category
3922 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3923 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3924 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3925 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3926 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3927 may be NULL, in which case they are not assigned.
3928
3929 [Currently, however, GCC does not generate subprogram renamings.] */
3930
3931enum ada_renaming_category
3932ada_parse_renaming (struct symbol *sym,
3933 const char **renamed_entity, int *len,
3934 const char **renaming_expr)
3935{
3936 enum ada_renaming_category kind;
3937 const char *info;
3938 const char *suffix;
3939
3940 if (sym == NULL)
3941 return ADA_NOT_RENAMING;
3942 switch (SYMBOL_CLASS (sym))
14f9c5c9 3943 {
aeb5907d
JB
3944 default:
3945 return ADA_NOT_RENAMING;
3946 case LOC_TYPEDEF:
3947 return parse_old_style_renaming (SYMBOL_TYPE (sym),
3948 renamed_entity, len, renaming_expr);
3949 case LOC_LOCAL:
3950 case LOC_STATIC:
3951 case LOC_COMPUTED:
3952 case LOC_OPTIMIZED_OUT:
3953 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
3954 if (info == NULL)
3955 return ADA_NOT_RENAMING;
3956 switch (info[5])
3957 {
3958 case '_':
3959 kind = ADA_OBJECT_RENAMING;
3960 info += 6;
3961 break;
3962 case 'E':
3963 kind = ADA_EXCEPTION_RENAMING;
3964 info += 7;
3965 break;
3966 case 'P':
3967 kind = ADA_PACKAGE_RENAMING;
3968 info += 7;
3969 break;
3970 case 'S':
3971 kind = ADA_SUBPROGRAM_RENAMING;
3972 info += 7;
3973 break;
3974 default:
3975 return ADA_NOT_RENAMING;
3976 }
14f9c5c9 3977 }
4c4b4cd2 3978
aeb5907d
JB
3979 if (renamed_entity != NULL)
3980 *renamed_entity = info;
3981 suffix = strstr (info, "___XE");
3982 if (suffix == NULL || suffix == info)
3983 return ADA_NOT_RENAMING;
3984 if (len != NULL)
3985 *len = strlen (info) - strlen (suffix);
3986 suffix += 5;
3987 if (renaming_expr != NULL)
3988 *renaming_expr = suffix;
3989 return kind;
3990}
3991
3992/* Assuming TYPE encodes a renaming according to the old encoding in
3993 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3994 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3995 ADA_NOT_RENAMING otherwise. */
3996static enum ada_renaming_category
3997parse_old_style_renaming (struct type *type,
3998 const char **renamed_entity, int *len,
3999 const char **renaming_expr)
4000{
4001 enum ada_renaming_category kind;
4002 const char *name;
4003 const char *info;
4004 const char *suffix;
14f9c5c9 4005
aeb5907d
JB
4006 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4007 || TYPE_NFIELDS (type) != 1)
4008 return ADA_NOT_RENAMING;
14f9c5c9 4009
aeb5907d
JB
4010 name = type_name_no_tag (type);
4011 if (name == NULL)
4012 return ADA_NOT_RENAMING;
4013
4014 name = strstr (name, "___XR");
4015 if (name == NULL)
4016 return ADA_NOT_RENAMING;
4017 switch (name[5])
4018 {
4019 case '\0':
4020 case '_':
4021 kind = ADA_OBJECT_RENAMING;
4022 break;
4023 case 'E':
4024 kind = ADA_EXCEPTION_RENAMING;
4025 break;
4026 case 'P':
4027 kind = ADA_PACKAGE_RENAMING;
4028 break;
4029 case 'S':
4030 kind = ADA_SUBPROGRAM_RENAMING;
4031 break;
4032 default:
4033 return ADA_NOT_RENAMING;
4034 }
14f9c5c9 4035
aeb5907d
JB
4036 info = TYPE_FIELD_NAME (type, 0);
4037 if (info == NULL)
4038 return ADA_NOT_RENAMING;
4039 if (renamed_entity != NULL)
4040 *renamed_entity = info;
4041 suffix = strstr (info, "___XE");
4042 if (renaming_expr != NULL)
4043 *renaming_expr = suffix + 5;
4044 if (suffix == NULL || suffix == info)
4045 return ADA_NOT_RENAMING;
4046 if (len != NULL)
4047 *len = suffix - info;
4048 return kind;
a5ee536b
JB
4049}
4050
4051/* Compute the value of the given RENAMING_SYM, which is expected to
4052 be a symbol encoding a renaming expression. BLOCK is the block
4053 used to evaluate the renaming. */
52ce6436 4054
a5ee536b
JB
4055static struct value *
4056ada_read_renaming_var_value (struct symbol *renaming_sym,
4057 struct block *block)
4058{
bbc13ae3 4059 const char *sym_name;
a5ee536b
JB
4060 struct expression *expr;
4061 struct value *value;
4062 struct cleanup *old_chain = NULL;
4063
bbc13ae3 4064 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
1bb9788d 4065 expr = parse_exp_1 (&sym_name, 0, block, 0);
bbc13ae3 4066 old_chain = make_cleanup (free_current_contents, &expr);
a5ee536b
JB
4067 value = evaluate_expression (expr);
4068
4069 do_cleanups (old_chain);
4070 return value;
4071}
14f9c5c9 4072\f
d2e4a39e 4073
4c4b4cd2 4074 /* Evaluation: Function Calls */
14f9c5c9 4075
4c4b4cd2 4076/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4077 lvalues, and otherwise has the side-effect of allocating memory
4078 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4079
d2e4a39e 4080static struct value *
40bc484c 4081ensure_lval (struct value *val)
14f9c5c9 4082{
40bc484c
JB
4083 if (VALUE_LVAL (val) == not_lval
4084 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4085 {
df407dfe 4086 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4087 const CORE_ADDR addr =
4088 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4089
40bc484c 4090 set_value_address (val, addr);
a84a8a0d 4091 VALUE_LVAL (val) = lval_memory;
40bc484c 4092 write_memory (addr, value_contents (val), len);
c3e5cd34 4093 }
14f9c5c9
AS
4094
4095 return val;
4096}
4097
4098/* Return the value ACTUAL, converted to be an appropriate value for a
4099 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4100 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4101 values not residing in memory, updating it as needed. */
14f9c5c9 4102
a93c0eb6 4103struct value *
40bc484c 4104ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4105{
df407dfe 4106 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4107 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4108 struct type *formal_target =
4109 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4110 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4111 struct type *actual_target =
4112 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4113 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4114
4c4b4cd2 4115 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4116 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4117 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4118 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4119 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4120 {
a84a8a0d 4121 struct value *result;
5b4ee69b 4122
14f9c5c9 4123 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4124 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4125 result = desc_data (actual);
14f9c5c9 4126 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4127 {
4128 if (VALUE_LVAL (actual) != lval_memory)
4129 {
4130 struct value *val;
5b4ee69b 4131
df407dfe 4132 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4133 val = allocate_value (actual_type);
990a07ab 4134 memcpy ((char *) value_contents_raw (val),
0fd88904 4135 (char *) value_contents (actual),
4c4b4cd2 4136 TYPE_LENGTH (actual_type));
40bc484c 4137 actual = ensure_lval (val);
4c4b4cd2 4138 }
a84a8a0d 4139 result = value_addr (actual);
4c4b4cd2 4140 }
a84a8a0d
JB
4141 else
4142 return actual;
b1af9e97 4143 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4144 }
4145 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4146 return ada_value_ind (actual);
4147
4148 return actual;
4149}
4150
438c98a1
JB
4151/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4152 type TYPE. This is usually an inefficient no-op except on some targets
4153 (such as AVR) where the representation of a pointer and an address
4154 differs. */
4155
4156static CORE_ADDR
4157value_pointer (struct value *value, struct type *type)
4158{
4159 struct gdbarch *gdbarch = get_type_arch (type);
4160 unsigned len = TYPE_LENGTH (type);
4161 gdb_byte *buf = alloca (len);
4162 CORE_ADDR addr;
4163
4164 addr = value_address (value);
4165 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4166 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4167 return addr;
4168}
4169
14f9c5c9 4170
4c4b4cd2
PH
4171/* Push a descriptor of type TYPE for array value ARR on the stack at
4172 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4173 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4174 to-descriptor type rather than a descriptor type), a struct value *
4175 representing a pointer to this descriptor. */
14f9c5c9 4176
d2e4a39e 4177static struct value *
40bc484c 4178make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4179{
d2e4a39e
AS
4180 struct type *bounds_type = desc_bounds_type (type);
4181 struct type *desc_type = desc_base_type (type);
4182 struct value *descriptor = allocate_value (desc_type);
4183 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4184 int i;
d2e4a39e 4185
0963b4bd
MS
4186 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4187 i > 0; i -= 1)
14f9c5c9 4188 {
19f220c3
JK
4189 modify_field (value_type (bounds), value_contents_writeable (bounds),
4190 ada_array_bound (arr, i, 0),
4191 desc_bound_bitpos (bounds_type, i, 0),
4192 desc_bound_bitsize (bounds_type, i, 0));
4193 modify_field (value_type (bounds), value_contents_writeable (bounds),
4194 ada_array_bound (arr, i, 1),
4195 desc_bound_bitpos (bounds_type, i, 1),
4196 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4197 }
d2e4a39e 4198
40bc484c 4199 bounds = ensure_lval (bounds);
d2e4a39e 4200
19f220c3
JK
4201 modify_field (value_type (descriptor),
4202 value_contents_writeable (descriptor),
4203 value_pointer (ensure_lval (arr),
4204 TYPE_FIELD_TYPE (desc_type, 0)),
4205 fat_pntr_data_bitpos (desc_type),
4206 fat_pntr_data_bitsize (desc_type));
4207
4208 modify_field (value_type (descriptor),
4209 value_contents_writeable (descriptor),
4210 value_pointer (bounds,
4211 TYPE_FIELD_TYPE (desc_type, 1)),
4212 fat_pntr_bounds_bitpos (desc_type),
4213 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4214
40bc484c 4215 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4216
4217 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4218 return value_addr (descriptor);
4219 else
4220 return descriptor;
4221}
14f9c5c9 4222\f
963a6417 4223/* Dummy definitions for an experimental caching module that is not
0963b4bd 4224 * used in the public sources. */
96d887e8 4225
96d887e8
PH
4226static int
4227lookup_cached_symbol (const char *name, domain_enum namespace,
2570f2b7 4228 struct symbol **sym, struct block **block)
96d887e8
PH
4229{
4230 return 0;
4231}
4232
4233static void
4234cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
270140bd 4235 const struct block *block)
96d887e8
PH
4236{
4237}
4c4b4cd2
PH
4238\f
4239 /* Symbol Lookup */
4240
c0431670
JB
4241/* Return nonzero if wild matching should be used when searching for
4242 all symbols matching LOOKUP_NAME.
4243
4244 LOOKUP_NAME is expected to be a symbol name after transformation
4245 for Ada lookups (see ada_name_for_lookup). */
4246
4247static int
4248should_use_wild_match (const char *lookup_name)
4249{
4250 return (strstr (lookup_name, "__") == NULL);
4251}
4252
4c4b4cd2
PH
4253/* Return the result of a standard (literal, C-like) lookup of NAME in
4254 given DOMAIN, visible from lexical block BLOCK. */
4255
4256static struct symbol *
4257standard_lookup (const char *name, const struct block *block,
4258 domain_enum domain)
4259{
acbd605d
MGD
4260 /* Initialize it just to avoid a GCC false warning. */
4261 struct symbol *sym = NULL;
4c4b4cd2 4262
2570f2b7 4263 if (lookup_cached_symbol (name, domain, &sym, NULL))
4c4b4cd2 4264 return sym;
2570f2b7
UW
4265 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4266 cache_symbol (name, domain, sym, block_found);
4c4b4cd2
PH
4267 return sym;
4268}
4269
4270
4271/* Non-zero iff there is at least one non-function/non-enumeral symbol
4272 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4273 since they contend in overloading in the same way. */
4274static int
4275is_nonfunction (struct ada_symbol_info syms[], int n)
4276{
4277 int i;
4278
4279 for (i = 0; i < n; i += 1)
4280 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
4281 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
4282 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
14f9c5c9
AS
4283 return 1;
4284
4285 return 0;
4286}
4287
4288/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4289 struct types. Otherwise, they may not. */
14f9c5c9
AS
4290
4291static int
d2e4a39e 4292equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4293{
d2e4a39e 4294 if (type0 == type1)
14f9c5c9 4295 return 1;
d2e4a39e 4296 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4297 || TYPE_CODE (type0) != TYPE_CODE (type1))
4298 return 0;
d2e4a39e 4299 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4300 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4301 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4302 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4303 return 1;
d2e4a39e 4304
14f9c5c9
AS
4305 return 0;
4306}
4307
4308/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4309 no more defined than that of SYM1. */
14f9c5c9
AS
4310
4311static int
d2e4a39e 4312lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4313{
4314 if (sym0 == sym1)
4315 return 1;
176620f1 4316 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4317 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4318 return 0;
4319
d2e4a39e 4320 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4321 {
4322 case LOC_UNDEF:
4323 return 1;
4324 case LOC_TYPEDEF:
4325 {
4c4b4cd2
PH
4326 struct type *type0 = SYMBOL_TYPE (sym0);
4327 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4328 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4329 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4330 int len0 = strlen (name0);
5b4ee69b 4331
4c4b4cd2
PH
4332 return
4333 TYPE_CODE (type0) == TYPE_CODE (type1)
4334 && (equiv_types (type0, type1)
4335 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4336 && strncmp (name1 + len0, "___XV", 5) == 0));
14f9c5c9
AS
4337 }
4338 case LOC_CONST:
4339 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4340 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4341 default:
4342 return 0;
14f9c5c9
AS
4343 }
4344}
4345
4c4b4cd2
PH
4346/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4347 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4348
4349static void
76a01679
JB
4350add_defn_to_vec (struct obstack *obstackp,
4351 struct symbol *sym,
2570f2b7 4352 struct block *block)
14f9c5c9
AS
4353{
4354 int i;
4c4b4cd2 4355 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4356
529cad9c
PH
4357 /* Do not try to complete stub types, as the debugger is probably
4358 already scanning all symbols matching a certain name at the
4359 time when this function is called. Trying to replace the stub
4360 type by its associated full type will cause us to restart a scan
4361 which may lead to an infinite recursion. Instead, the client
4362 collecting the matching symbols will end up collecting several
4363 matches, with at least one of them complete. It can then filter
4364 out the stub ones if needed. */
4365
4c4b4cd2
PH
4366 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4367 {
4368 if (lesseq_defined_than (sym, prevDefns[i].sym))
4369 return;
4370 else if (lesseq_defined_than (prevDefns[i].sym, sym))
4371 {
4372 prevDefns[i].sym = sym;
4373 prevDefns[i].block = block;
4c4b4cd2 4374 return;
76a01679 4375 }
4c4b4cd2
PH
4376 }
4377
4378 {
4379 struct ada_symbol_info info;
4380
4381 info.sym = sym;
4382 info.block = block;
4c4b4cd2
PH
4383 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
4384 }
4385}
4386
4387/* Number of ada_symbol_info structures currently collected in
4388 current vector in *OBSTACKP. */
4389
76a01679
JB
4390static int
4391num_defns_collected (struct obstack *obstackp)
4c4b4cd2
PH
4392{
4393 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
4394}
4395
4396/* Vector of ada_symbol_info structures currently collected in current
4397 vector in *OBSTACKP. If FINISH, close off the vector and return
4398 its final address. */
4399
76a01679 4400static struct ada_symbol_info *
4c4b4cd2
PH
4401defns_collected (struct obstack *obstackp, int finish)
4402{
4403 if (finish)
4404 return obstack_finish (obstackp);
4405 else
4406 return (struct ada_symbol_info *) obstack_base (obstackp);
4407}
4408
7c7b6655
TT
4409/* Return a bound minimal symbol matching NAME according to Ada
4410 decoding rules. Returns an invalid symbol if there is no such
4411 minimal symbol. Names prefixed with "standard__" are handled
4412 specially: "standard__" is first stripped off, and only static and
4413 global symbols are searched. */
4c4b4cd2 4414
7c7b6655 4415struct bound_minimal_symbol
96d887e8 4416ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4417{
7c7b6655 4418 struct bound_minimal_symbol result;
4c4b4cd2 4419 struct objfile *objfile;
96d887e8 4420 struct minimal_symbol *msymbol;
dc4024cd 4421 const int wild_match_p = should_use_wild_match (name);
4c4b4cd2 4422
7c7b6655
TT
4423 memset (&result, 0, sizeof (result));
4424
c0431670
JB
4425 /* Special case: If the user specifies a symbol name inside package
4426 Standard, do a non-wild matching of the symbol name without
4427 the "standard__" prefix. This was primarily introduced in order
4428 to allow the user to specifically access the standard exceptions
4429 using, for instance, Standard.Constraint_Error when Constraint_Error
4430 is ambiguous (due to the user defining its own Constraint_Error
4431 entity inside its program). */
96d887e8 4432 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
c0431670 4433 name += sizeof ("standard__") - 1;
4c4b4cd2 4434
96d887e8
PH
4435 ALL_MSYMBOLS (objfile, msymbol)
4436 {
dc4024cd 4437 if (match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match_p)
96d887e8 4438 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
7c7b6655
TT
4439 {
4440 result.minsym = msymbol;
4441 result.objfile = objfile;
4442 break;
4443 }
96d887e8 4444 }
4c4b4cd2 4445
7c7b6655 4446 return result;
96d887e8 4447}
4c4b4cd2 4448
96d887e8
PH
4449/* For all subprograms that statically enclose the subprogram of the
4450 selected frame, add symbols matching identifier NAME in DOMAIN
4451 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4452 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4453 with a wildcard prefix. */
4c4b4cd2 4454
96d887e8
PH
4455static void
4456add_symbols_from_enclosing_procs (struct obstack *obstackp,
76a01679 4457 const char *name, domain_enum namespace,
48b78332 4458 int wild_match_p)
96d887e8 4459{
96d887e8 4460}
14f9c5c9 4461
96d887e8
PH
4462/* True if TYPE is definitely an artificial type supplied to a symbol
4463 for which no debugging information was given in the symbol file. */
14f9c5c9 4464
96d887e8
PH
4465static int
4466is_nondebugging_type (struct type *type)
4467{
0d5cff50 4468 const char *name = ada_type_name (type);
5b4ee69b 4469
96d887e8
PH
4470 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4471}
4c4b4cd2 4472
8f17729f
JB
4473/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4474 that are deemed "identical" for practical purposes.
4475
4476 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4477 types and that their number of enumerals is identical (in other
4478 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4479
4480static int
4481ada_identical_enum_types_p (struct type *type1, struct type *type2)
4482{
4483 int i;
4484
4485 /* The heuristic we use here is fairly conservative. We consider
4486 that 2 enumerate types are identical if they have the same
4487 number of enumerals and that all enumerals have the same
4488 underlying value and name. */
4489
4490 /* All enums in the type should have an identical underlying value. */
4491 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 4492 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
4493 return 0;
4494
4495 /* All enumerals should also have the same name (modulo any numerical
4496 suffix). */
4497 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4498 {
0d5cff50
DE
4499 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4500 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
4501 int len_1 = strlen (name_1);
4502 int len_2 = strlen (name_2);
4503
4504 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4505 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4506 if (len_1 != len_2
4507 || strncmp (TYPE_FIELD_NAME (type1, i),
4508 TYPE_FIELD_NAME (type2, i),
4509 len_1) != 0)
4510 return 0;
4511 }
4512
4513 return 1;
4514}
4515
4516/* Return nonzero if all the symbols in SYMS are all enumeral symbols
4517 that are deemed "identical" for practical purposes. Sometimes,
4518 enumerals are not strictly identical, but their types are so similar
4519 that they can be considered identical.
4520
4521 For instance, consider the following code:
4522
4523 type Color is (Black, Red, Green, Blue, White);
4524 type RGB_Color is new Color range Red .. Blue;
4525
4526 Type RGB_Color is a subrange of an implicit type which is a copy
4527 of type Color. If we call that implicit type RGB_ColorB ("B" is
4528 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4529 As a result, when an expression references any of the enumeral
4530 by name (Eg. "print green"), the expression is technically
4531 ambiguous and the user should be asked to disambiguate. But
4532 doing so would only hinder the user, since it wouldn't matter
4533 what choice he makes, the outcome would always be the same.
4534 So, for practical purposes, we consider them as the same. */
4535
4536static int
4537symbols_are_identical_enums (struct ada_symbol_info *syms, int nsyms)
4538{
4539 int i;
4540
4541 /* Before performing a thorough comparison check of each type,
4542 we perform a series of inexpensive checks. We expect that these
4543 checks will quickly fail in the vast majority of cases, and thus
4544 help prevent the unnecessary use of a more expensive comparison.
4545 Said comparison also expects us to make some of these checks
4546 (see ada_identical_enum_types_p). */
4547
4548 /* Quick check: All symbols should have an enum type. */
4549 for (i = 0; i < nsyms; i++)
4550 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM)
4551 return 0;
4552
4553 /* Quick check: They should all have the same value. */
4554 for (i = 1; i < nsyms; i++)
4555 if (SYMBOL_VALUE (syms[i].sym) != SYMBOL_VALUE (syms[0].sym))
4556 return 0;
4557
4558 /* Quick check: They should all have the same number of enumerals. */
4559 for (i = 1; i < nsyms; i++)
4560 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].sym))
4561 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].sym)))
4562 return 0;
4563
4564 /* All the sanity checks passed, so we might have a set of
4565 identical enumeration types. Perform a more complete
4566 comparison of the type of each symbol. */
4567 for (i = 1; i < nsyms; i++)
4568 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].sym),
4569 SYMBOL_TYPE (syms[0].sym)))
4570 return 0;
4571
4572 return 1;
4573}
4574
96d887e8
PH
4575/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4576 duplicate other symbols in the list (The only case I know of where
4577 this happens is when object files containing stabs-in-ecoff are
4578 linked with files containing ordinary ecoff debugging symbols (or no
4579 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4580 Returns the number of items in the modified list. */
4c4b4cd2 4581
96d887e8
PH
4582static int
4583remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4584{
4585 int i, j;
4c4b4cd2 4586
8f17729f
JB
4587 /* We should never be called with less than 2 symbols, as there
4588 cannot be any extra symbol in that case. But it's easy to
4589 handle, since we have nothing to do in that case. */
4590 if (nsyms < 2)
4591 return nsyms;
4592
96d887e8
PH
4593 i = 0;
4594 while (i < nsyms)
4595 {
a35ddb44 4596 int remove_p = 0;
339c13b6
JB
4597
4598 /* If two symbols have the same name and one of them is a stub type,
4599 the get rid of the stub. */
4600
4601 if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym))
4602 && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL)
4603 {
4604 for (j = 0; j < nsyms; j++)
4605 {
4606 if (j != i
4607 && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym))
4608 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4609 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4610 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0)
a35ddb44 4611 remove_p = 1;
339c13b6
JB
4612 }
4613 }
4614
4615 /* Two symbols with the same name, same class and same address
4616 should be identical. */
4617
4618 else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
96d887e8
PH
4619 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4620 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4621 {
4622 for (j = 0; j < nsyms; j += 1)
4623 {
4624 if (i != j
4625 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4626 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
76a01679 4627 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
96d887e8
PH
4628 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4629 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4630 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
a35ddb44 4631 remove_p = 1;
4c4b4cd2 4632 }
4c4b4cd2 4633 }
339c13b6 4634
a35ddb44 4635 if (remove_p)
339c13b6
JB
4636 {
4637 for (j = i + 1; j < nsyms; j += 1)
4638 syms[j - 1] = syms[j];
4639 nsyms -= 1;
4640 }
4641
96d887e8 4642 i += 1;
14f9c5c9 4643 }
8f17729f
JB
4644
4645 /* If all the remaining symbols are identical enumerals, then
4646 just keep the first one and discard the rest.
4647
4648 Unlike what we did previously, we do not discard any entry
4649 unless they are ALL identical. This is because the symbol
4650 comparison is not a strict comparison, but rather a practical
4651 comparison. If all symbols are considered identical, then
4652 we can just go ahead and use the first one and discard the rest.
4653 But if we cannot reduce the list to a single element, we have
4654 to ask the user to disambiguate anyways. And if we have to
4655 present a multiple-choice menu, it's less confusing if the list
4656 isn't missing some choices that were identical and yet distinct. */
4657 if (symbols_are_identical_enums (syms, nsyms))
4658 nsyms = 1;
4659
96d887e8 4660 return nsyms;
14f9c5c9
AS
4661}
4662
96d887e8
PH
4663/* Given a type that corresponds to a renaming entity, use the type name
4664 to extract the scope (package name or function name, fully qualified,
4665 and following the GNAT encoding convention) where this renaming has been
4666 defined. The string returned needs to be deallocated after use. */
4c4b4cd2 4667
96d887e8
PH
4668static char *
4669xget_renaming_scope (struct type *renaming_type)
14f9c5c9 4670{
96d887e8 4671 /* The renaming types adhere to the following convention:
0963b4bd 4672 <scope>__<rename>___<XR extension>.
96d887e8
PH
4673 So, to extract the scope, we search for the "___XR" extension,
4674 and then backtrack until we find the first "__". */
76a01679 4675
96d887e8
PH
4676 const char *name = type_name_no_tag (renaming_type);
4677 char *suffix = strstr (name, "___XR");
4678 char *last;
4679 int scope_len;
4680 char *scope;
14f9c5c9 4681
96d887e8
PH
4682 /* Now, backtrack a bit until we find the first "__". Start looking
4683 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 4684
96d887e8
PH
4685 for (last = suffix - 3; last > name; last--)
4686 if (last[0] == '_' && last[1] == '_')
4687 break;
76a01679 4688
96d887e8 4689 /* Make a copy of scope and return it. */
14f9c5c9 4690
96d887e8
PH
4691 scope_len = last - name;
4692 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
14f9c5c9 4693
96d887e8
PH
4694 strncpy (scope, name, scope_len);
4695 scope[scope_len] = '\0';
4c4b4cd2 4696
96d887e8 4697 return scope;
4c4b4cd2
PH
4698}
4699
96d887e8 4700/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 4701
96d887e8
PH
4702static int
4703is_package_name (const char *name)
4c4b4cd2 4704{
96d887e8
PH
4705 /* Here, We take advantage of the fact that no symbols are generated
4706 for packages, while symbols are generated for each function.
4707 So the condition for NAME represent a package becomes equivalent
4708 to NAME not existing in our list of symbols. There is only one
4709 small complication with library-level functions (see below). */
4c4b4cd2 4710
96d887e8 4711 char *fun_name;
76a01679 4712
96d887e8
PH
4713 /* If it is a function that has not been defined at library level,
4714 then we should be able to look it up in the symbols. */
4715 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4716 return 0;
14f9c5c9 4717
96d887e8
PH
4718 /* Library-level function names start with "_ada_". See if function
4719 "_ada_" followed by NAME can be found. */
14f9c5c9 4720
96d887e8 4721 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 4722 functions names cannot contain "__" in them. */
96d887e8
PH
4723 if (strstr (name, "__") != NULL)
4724 return 0;
4c4b4cd2 4725
b435e160 4726 fun_name = xstrprintf ("_ada_%s", name);
14f9c5c9 4727
96d887e8
PH
4728 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4729}
14f9c5c9 4730
96d887e8 4731/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 4732 not visible from FUNCTION_NAME. */
14f9c5c9 4733
96d887e8 4734static int
0d5cff50 4735old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 4736{
aeb5907d 4737 char *scope;
1509e573 4738 struct cleanup *old_chain;
aeb5907d
JB
4739
4740 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4741 return 0;
4742
4743 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
1509e573 4744 old_chain = make_cleanup (xfree, scope);
14f9c5c9 4745
96d887e8
PH
4746 /* If the rename has been defined in a package, then it is visible. */
4747 if (is_package_name (scope))
1509e573
JB
4748 {
4749 do_cleanups (old_chain);
4750 return 0;
4751 }
14f9c5c9 4752
96d887e8
PH
4753 /* Check that the rename is in the current function scope by checking
4754 that its name starts with SCOPE. */
76a01679 4755
96d887e8
PH
4756 /* If the function name starts with "_ada_", it means that it is
4757 a library-level function. Strip this prefix before doing the
4758 comparison, as the encoding for the renaming does not contain
4759 this prefix. */
4760 if (strncmp (function_name, "_ada_", 5) == 0)
4761 function_name += 5;
f26caa11 4762
1509e573
JB
4763 {
4764 int is_invisible = strncmp (function_name, scope, strlen (scope)) != 0;
4765
4766 do_cleanups (old_chain);
4767 return is_invisible;
4768 }
f26caa11
PH
4769}
4770
aeb5907d
JB
4771/* Remove entries from SYMS that corresponds to a renaming entity that
4772 is not visible from the function associated with CURRENT_BLOCK or
4773 that is superfluous due to the presence of more specific renaming
4774 information. Places surviving symbols in the initial entries of
4775 SYMS and returns the number of surviving symbols.
96d887e8
PH
4776
4777 Rationale:
aeb5907d
JB
4778 First, in cases where an object renaming is implemented as a
4779 reference variable, GNAT may produce both the actual reference
4780 variable and the renaming encoding. In this case, we discard the
4781 latter.
4782
4783 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
4784 entity. Unfortunately, STABS currently does not support the definition
4785 of types that are local to a given lexical block, so all renamings types
4786 are emitted at library level. As a consequence, if an application
4787 contains two renaming entities using the same name, and a user tries to
4788 print the value of one of these entities, the result of the ada symbol
4789 lookup will also contain the wrong renaming type.
f26caa11 4790
96d887e8
PH
4791 This function partially covers for this limitation by attempting to
4792 remove from the SYMS list renaming symbols that should be visible
4793 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4794 method with the current information available. The implementation
4795 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4796
4797 - When the user tries to print a rename in a function while there
4798 is another rename entity defined in a package: Normally, the
4799 rename in the function has precedence over the rename in the
4800 package, so the latter should be removed from the list. This is
4801 currently not the case.
4802
4803 - This function will incorrectly remove valid renames if
4804 the CURRENT_BLOCK corresponds to a function which symbol name
4805 has been changed by an "Export" pragma. As a consequence,
4806 the user will be unable to print such rename entities. */
4c4b4cd2 4807
14f9c5c9 4808static int
aeb5907d
JB
4809remove_irrelevant_renamings (struct ada_symbol_info *syms,
4810 int nsyms, const struct block *current_block)
4c4b4cd2
PH
4811{
4812 struct symbol *current_function;
0d5cff50 4813 const char *current_function_name;
4c4b4cd2 4814 int i;
aeb5907d
JB
4815 int is_new_style_renaming;
4816
4817 /* If there is both a renaming foo___XR... encoded as a variable and
4818 a simple variable foo in the same block, discard the latter.
0963b4bd 4819 First, zero out such symbols, then compress. */
aeb5907d
JB
4820 is_new_style_renaming = 0;
4821 for (i = 0; i < nsyms; i += 1)
4822 {
4823 struct symbol *sym = syms[i].sym;
270140bd 4824 const struct block *block = syms[i].block;
aeb5907d
JB
4825 const char *name;
4826 const char *suffix;
4827
4828 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4829 continue;
4830 name = SYMBOL_LINKAGE_NAME (sym);
4831 suffix = strstr (name, "___XR");
4832
4833 if (suffix != NULL)
4834 {
4835 int name_len = suffix - name;
4836 int j;
5b4ee69b 4837
aeb5907d
JB
4838 is_new_style_renaming = 1;
4839 for (j = 0; j < nsyms; j += 1)
4840 if (i != j && syms[j].sym != NULL
4841 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
4842 name_len) == 0
4843 && block == syms[j].block)
4844 syms[j].sym = NULL;
4845 }
4846 }
4847 if (is_new_style_renaming)
4848 {
4849 int j, k;
4850
4851 for (j = k = 0; j < nsyms; j += 1)
4852 if (syms[j].sym != NULL)
4853 {
4854 syms[k] = syms[j];
4855 k += 1;
4856 }
4857 return k;
4858 }
4c4b4cd2
PH
4859
4860 /* Extract the function name associated to CURRENT_BLOCK.
4861 Abort if unable to do so. */
76a01679 4862
4c4b4cd2
PH
4863 if (current_block == NULL)
4864 return nsyms;
76a01679 4865
7f0df278 4866 current_function = block_linkage_function (current_block);
4c4b4cd2
PH
4867 if (current_function == NULL)
4868 return nsyms;
4869
4870 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
4871 if (current_function_name == NULL)
4872 return nsyms;
4873
4874 /* Check each of the symbols, and remove it from the list if it is
4875 a type corresponding to a renaming that is out of the scope of
4876 the current block. */
4877
4878 i = 0;
4879 while (i < nsyms)
4880 {
aeb5907d
JB
4881 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
4882 == ADA_OBJECT_RENAMING
4883 && old_renaming_is_invisible (syms[i].sym, current_function_name))
4c4b4cd2
PH
4884 {
4885 int j;
5b4ee69b 4886
aeb5907d 4887 for (j = i + 1; j < nsyms; j += 1)
76a01679 4888 syms[j - 1] = syms[j];
4c4b4cd2
PH
4889 nsyms -= 1;
4890 }
4891 else
4892 i += 1;
4893 }
4894
4895 return nsyms;
4896}
4897
339c13b6
JB
4898/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4899 whose name and domain match NAME and DOMAIN respectively.
4900 If no match was found, then extend the search to "enclosing"
4901 routines (in other words, if we're inside a nested function,
4902 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
4903 If WILD_MATCH_P is nonzero, perform the naming matching in
4904 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
4905
4906 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4907
4908static void
4909ada_add_local_symbols (struct obstack *obstackp, const char *name,
4910 struct block *block, domain_enum domain,
d0a8ab18 4911 int wild_match_p)
339c13b6
JB
4912{
4913 int block_depth = 0;
4914
4915 while (block != NULL)
4916 {
4917 block_depth += 1;
d0a8ab18
JB
4918 ada_add_block_symbols (obstackp, block, name, domain, NULL,
4919 wild_match_p);
339c13b6
JB
4920
4921 /* If we found a non-function match, assume that's the one. */
4922 if (is_nonfunction (defns_collected (obstackp, 0),
4923 num_defns_collected (obstackp)))
4924 return;
4925
4926 block = BLOCK_SUPERBLOCK (block);
4927 }
4928
4929 /* If no luck so far, try to find NAME as a local symbol in some lexically
4930 enclosing subprogram. */
4931 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
d0a8ab18 4932 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match_p);
339c13b6
JB
4933}
4934
ccefe4c4 4935/* An object of this type is used as the user_data argument when
40658b94 4936 calling the map_matching_symbols method. */
ccefe4c4 4937
40658b94 4938struct match_data
ccefe4c4 4939{
40658b94 4940 struct objfile *objfile;
ccefe4c4 4941 struct obstack *obstackp;
40658b94
PH
4942 struct symbol *arg_sym;
4943 int found_sym;
ccefe4c4
TT
4944};
4945
40658b94
PH
4946/* A callback for add_matching_symbols that adds SYM, found in BLOCK,
4947 to a list of symbols. DATA0 is a pointer to a struct match_data *
4948 containing the obstack that collects the symbol list, the file that SYM
4949 must come from, a flag indicating whether a non-argument symbol has
4950 been found in the current block, and the last argument symbol
4951 passed in SYM within the current block (if any). When SYM is null,
4952 marking the end of a block, the argument symbol is added if no
4953 other has been found. */
ccefe4c4 4954
40658b94
PH
4955static int
4956aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 4957{
40658b94
PH
4958 struct match_data *data = (struct match_data *) data0;
4959
4960 if (sym == NULL)
4961 {
4962 if (!data->found_sym && data->arg_sym != NULL)
4963 add_defn_to_vec (data->obstackp,
4964 fixup_symbol_section (data->arg_sym, data->objfile),
4965 block);
4966 data->found_sym = 0;
4967 data->arg_sym = NULL;
4968 }
4969 else
4970 {
4971 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
4972 return 0;
4973 else if (SYMBOL_IS_ARGUMENT (sym))
4974 data->arg_sym = sym;
4975 else
4976 {
4977 data->found_sym = 1;
4978 add_defn_to_vec (data->obstackp,
4979 fixup_symbol_section (sym, data->objfile),
4980 block);
4981 }
4982 }
4983 return 0;
4984}
4985
db230ce3
JB
4986/* Implements compare_names, but only applying the comparision using
4987 the given CASING. */
5b4ee69b 4988
40658b94 4989static int
db230ce3
JB
4990compare_names_with_case (const char *string1, const char *string2,
4991 enum case_sensitivity casing)
40658b94
PH
4992{
4993 while (*string1 != '\0' && *string2 != '\0')
4994 {
db230ce3
JB
4995 char c1, c2;
4996
40658b94
PH
4997 if (isspace (*string1) || isspace (*string2))
4998 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
4999
5000 if (casing == case_sensitive_off)
5001 {
5002 c1 = tolower (*string1);
5003 c2 = tolower (*string2);
5004 }
5005 else
5006 {
5007 c1 = *string1;
5008 c2 = *string2;
5009 }
5010 if (c1 != c2)
40658b94 5011 break;
db230ce3 5012
40658b94
PH
5013 string1 += 1;
5014 string2 += 1;
5015 }
db230ce3 5016
40658b94
PH
5017 switch (*string1)
5018 {
5019 case '(':
5020 return strcmp_iw_ordered (string1, string2);
5021 case '_':
5022 if (*string2 == '\0')
5023 {
052874e8 5024 if (is_name_suffix (string1))
40658b94
PH
5025 return 0;
5026 else
1a1d5513 5027 return 1;
40658b94 5028 }
dbb8534f 5029 /* FALLTHROUGH */
40658b94
PH
5030 default:
5031 if (*string2 == '(')
5032 return strcmp_iw_ordered (string1, string2);
5033 else
db230ce3
JB
5034 {
5035 if (casing == case_sensitive_off)
5036 return tolower (*string1) - tolower (*string2);
5037 else
5038 return *string1 - *string2;
5039 }
40658b94 5040 }
ccefe4c4
TT
5041}
5042
db230ce3
JB
5043/* Compare STRING1 to STRING2, with results as for strcmp.
5044 Compatible with strcmp_iw_ordered in that...
5045
5046 strcmp_iw_ordered (STRING1, STRING2) <= 0
5047
5048 ... implies...
5049
5050 compare_names (STRING1, STRING2) <= 0
5051
5052 (they may differ as to what symbols compare equal). */
5053
5054static int
5055compare_names (const char *string1, const char *string2)
5056{
5057 int result;
5058
5059 /* Similar to what strcmp_iw_ordered does, we need to perform
5060 a case-insensitive comparison first, and only resort to
5061 a second, case-sensitive, comparison if the first one was
5062 not sufficient to differentiate the two strings. */
5063
5064 result = compare_names_with_case (string1, string2, case_sensitive_off);
5065 if (result == 0)
5066 result = compare_names_with_case (string1, string2, case_sensitive_on);
5067
5068 return result;
5069}
5070
339c13b6
JB
5071/* Add to OBSTACKP all non-local symbols whose name and domain match
5072 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
5073 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
5074
5075static void
40658b94
PH
5076add_nonlocal_symbols (struct obstack *obstackp, const char *name,
5077 domain_enum domain, int global,
5078 int is_wild_match)
339c13b6
JB
5079{
5080 struct objfile *objfile;
40658b94 5081 struct match_data data;
339c13b6 5082
6475f2fe 5083 memset (&data, 0, sizeof data);
ccefe4c4 5084 data.obstackp = obstackp;
339c13b6 5085
ccefe4c4 5086 ALL_OBJFILES (objfile)
40658b94
PH
5087 {
5088 data.objfile = objfile;
5089
5090 if (is_wild_match)
ade7ed9e 5091 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
40658b94
PH
5092 aux_add_nonlocal_symbols, &data,
5093 wild_match, NULL);
5094 else
ade7ed9e 5095 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
40658b94
PH
5096 aux_add_nonlocal_symbols, &data,
5097 full_match, compare_names);
5098 }
5099
5100 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5101 {
5102 ALL_OBJFILES (objfile)
5103 {
5104 char *name1 = alloca (strlen (name) + sizeof ("_ada_"));
5105 strcpy (name1, "_ada_");
5106 strcpy (name1 + sizeof ("_ada_") - 1, name);
5107 data.objfile = objfile;
ade7ed9e
DE
5108 objfile->sf->qf->map_matching_symbols (objfile, name1, domain,
5109 global,
0963b4bd
MS
5110 aux_add_nonlocal_symbols,
5111 &data,
40658b94
PH
5112 full_match, compare_names);
5113 }
5114 }
339c13b6
JB
5115}
5116
4eeaa230
DE
5117/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and, if full_search is
5118 non-zero, enclosing scope and in global scopes, returning the number of
5119 matches.
9f88c959 5120 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4c4b4cd2 5121 indicating the symbols found and the blocks and symbol tables (if
4eeaa230
DE
5122 any) in which they were found. This vector is transient---good only to
5123 the next call of ada_lookup_symbol_list.
5124
5125 When full_search is non-zero, any non-function/non-enumeral
4c4b4cd2
PH
5126 symbol match within the nest of blocks whose innermost member is BLOCK0,
5127 is the one match returned (no other matches in that or
d9680e73 5128 enclosing blocks is returned). If there are any matches in or
4eeaa230
DE
5129 surrounding BLOCK0, then these alone are returned.
5130
9f88c959 5131 Names prefixed with "standard__" are handled specially: "standard__"
4c4b4cd2 5132 is first stripped off, and only static and global symbols are searched. */
14f9c5c9 5133
4eeaa230
DE
5134static int
5135ada_lookup_symbol_list_worker (const char *name0, const struct block *block0,
5136 domain_enum namespace,
5137 struct ada_symbol_info **results,
5138 int full_search)
14f9c5c9
AS
5139{
5140 struct symbol *sym;
14f9c5c9 5141 struct block *block;
4c4b4cd2 5142 const char *name;
82ccd55e 5143 const int wild_match_p = should_use_wild_match (name0);
14f9c5c9 5144 int cacheIfUnique;
4c4b4cd2 5145 int ndefns;
14f9c5c9 5146
4c4b4cd2
PH
5147 obstack_free (&symbol_list_obstack, NULL);
5148 obstack_init (&symbol_list_obstack);
14f9c5c9 5149
14f9c5c9
AS
5150 cacheIfUnique = 0;
5151
5152 /* Search specified block and its superiors. */
5153
4c4b4cd2 5154 name = name0;
76a01679
JB
5155 block = (struct block *) block0; /* FIXME: No cast ought to be
5156 needed, but adding const will
5157 have a cascade effect. */
339c13b6
JB
5158
5159 /* Special case: If the user specifies a symbol name inside package
5160 Standard, do a non-wild matching of the symbol name without
5161 the "standard__" prefix. This was primarily introduced in order
5162 to allow the user to specifically access the standard exceptions
5163 using, for instance, Standard.Constraint_Error when Constraint_Error
5164 is ambiguous (due to the user defining its own Constraint_Error
5165 entity inside its program). */
4c4b4cd2
PH
5166 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
5167 {
4c4b4cd2
PH
5168 block = NULL;
5169 name = name0 + sizeof ("standard__") - 1;
5170 }
5171
339c13b6 5172 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5173
4eeaa230
DE
5174 if (block != NULL)
5175 {
5176 if (full_search)
5177 {
5178 ada_add_local_symbols (&symbol_list_obstack, name, block,
5179 namespace, wild_match_p);
5180 }
5181 else
5182 {
5183 /* In the !full_search case we're are being called by
5184 ada_iterate_over_symbols, and we don't want to search
5185 superblocks. */
5186 ada_add_block_symbols (&symbol_list_obstack, block, name,
5187 namespace, NULL, wild_match_p);
5188 }
5189 if (num_defns_collected (&symbol_list_obstack) > 0 || !full_search)
5190 goto done;
5191 }
d2e4a39e 5192
339c13b6
JB
5193 /* No non-global symbols found. Check our cache to see if we have
5194 already performed this search before. If we have, then return
5195 the same result. */
5196
14f9c5c9 5197 cacheIfUnique = 1;
2570f2b7 5198 if (lookup_cached_symbol (name0, namespace, &sym, &block))
4c4b4cd2
PH
5199 {
5200 if (sym != NULL)
2570f2b7 5201 add_defn_to_vec (&symbol_list_obstack, sym, block);
4c4b4cd2
PH
5202 goto done;
5203 }
14f9c5c9 5204
339c13b6
JB
5205 /* Search symbols from all global blocks. */
5206
40658b94 5207 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 1,
82ccd55e 5208 wild_match_p);
d2e4a39e 5209
4c4b4cd2 5210 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5211 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5212
4c4b4cd2 5213 if (num_defns_collected (&symbol_list_obstack) == 0)
40658b94 5214 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 0,
82ccd55e 5215 wild_match_p);
14f9c5c9 5216
4c4b4cd2
PH
5217done:
5218 ndefns = num_defns_collected (&symbol_list_obstack);
5219 *results = defns_collected (&symbol_list_obstack, 1);
5220
5221 ndefns = remove_extra_symbols (*results, ndefns);
5222
2ad01556 5223 if (ndefns == 0 && full_search)
2570f2b7 5224 cache_symbol (name0, namespace, NULL, NULL);
14f9c5c9 5225
2ad01556 5226 if (ndefns == 1 && full_search && cacheIfUnique)
2570f2b7 5227 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
14f9c5c9 5228
aeb5907d 5229 ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
14f9c5c9 5230
14f9c5c9
AS
5231 return ndefns;
5232}
5233
4eeaa230
DE
5234/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and
5235 in global scopes, returning the number of matches, and setting *RESULTS
5236 to a vector of (SYM,BLOCK) tuples.
5237 See ada_lookup_symbol_list_worker for further details. */
5238
5239int
5240ada_lookup_symbol_list (const char *name0, const struct block *block0,
5241 domain_enum domain, struct ada_symbol_info **results)
5242{
5243 return ada_lookup_symbol_list_worker (name0, block0, domain, results, 1);
5244}
5245
5246/* Implementation of the la_iterate_over_symbols method. */
5247
5248static void
5249ada_iterate_over_symbols (const struct block *block,
5250 const char *name, domain_enum domain,
5251 symbol_found_callback_ftype *callback,
5252 void *data)
5253{
5254 int ndefs, i;
5255 struct ada_symbol_info *results;
5256
5257 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5258 for (i = 0; i < ndefs; ++i)
5259 {
5260 if (! (*callback) (results[i].sym, data))
5261 break;
5262 }
5263}
5264
f8eba3c6
TT
5265/* If NAME is the name of an entity, return a string that should
5266 be used to look that entity up in Ada units. This string should
5267 be deallocated after use using xfree.
5268
5269 NAME can have any form that the "break" or "print" commands might
5270 recognize. In other words, it does not have to be the "natural"
5271 name, or the "encoded" name. */
5272
5273char *
5274ada_name_for_lookup (const char *name)
5275{
5276 char *canon;
5277 int nlen = strlen (name);
5278
5279 if (name[0] == '<' && name[nlen - 1] == '>')
5280 {
5281 canon = xmalloc (nlen - 1);
5282 memcpy (canon, name + 1, nlen - 2);
5283 canon[nlen - 2] = '\0';
5284 }
5285 else
5286 canon = xstrdup (ada_encode (ada_fold_name (name)));
5287 return canon;
5288}
5289
4e5c77fe
JB
5290/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5291 to 1, but choosing the first symbol found if there are multiple
5292 choices.
5293
5e2336be
JB
5294 The result is stored in *INFO, which must be non-NULL.
5295 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5296
5297void
5298ada_lookup_encoded_symbol (const char *name, const struct block *block,
5299 domain_enum namespace,
5e2336be 5300 struct ada_symbol_info *info)
14f9c5c9 5301{
4c4b4cd2 5302 struct ada_symbol_info *candidates;
14f9c5c9
AS
5303 int n_candidates;
5304
5e2336be
JB
5305 gdb_assert (info != NULL);
5306 memset (info, 0, sizeof (struct ada_symbol_info));
4e5c77fe 5307
4eeaa230 5308 n_candidates = ada_lookup_symbol_list (name, block, namespace, &candidates);
14f9c5c9 5309 if (n_candidates == 0)
4e5c77fe 5310 return;
4c4b4cd2 5311
5e2336be
JB
5312 *info = candidates[0];
5313 info->sym = fixup_symbol_section (info->sym, NULL);
4e5c77fe 5314}
aeb5907d
JB
5315
5316/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5317 scope and in global scopes, or NULL if none. NAME is folded and
5318 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5319 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5320 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5321
aeb5907d
JB
5322struct symbol *
5323ada_lookup_symbol (const char *name, const struct block *block0,
21b556f4 5324 domain_enum namespace, int *is_a_field_of_this)
aeb5907d 5325{
5e2336be 5326 struct ada_symbol_info info;
4e5c77fe 5327
aeb5907d
JB
5328 if (is_a_field_of_this != NULL)
5329 *is_a_field_of_this = 0;
5330
4e5c77fe 5331 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
5e2336be
JB
5332 block0, namespace, &info);
5333 return info.sym;
4c4b4cd2 5334}
14f9c5c9 5335
4c4b4cd2
PH
5336static struct symbol *
5337ada_lookup_symbol_nonlocal (const char *name,
76a01679 5338 const struct block *block,
21b556f4 5339 const domain_enum domain)
4c4b4cd2 5340{
94af9270 5341 return ada_lookup_symbol (name, block_static_block (block), domain, NULL);
14f9c5c9
AS
5342}
5343
5344
4c4b4cd2
PH
5345/* True iff STR is a possible encoded suffix of a normal Ada name
5346 that is to be ignored for matching purposes. Suffixes of parallel
5347 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5348 are given by any of the regular expressions:
4c4b4cd2 5349
babe1480
JB
5350 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5351 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5352 TKB [subprogram suffix for task bodies]
babe1480 5353 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5354 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5355
5356 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5357 match is performed. This sequence is used to differentiate homonyms,
5358 is an optional part of a valid name suffix. */
4c4b4cd2 5359
14f9c5c9 5360static int
d2e4a39e 5361is_name_suffix (const char *str)
14f9c5c9
AS
5362{
5363 int k;
4c4b4cd2
PH
5364 const char *matching;
5365 const int len = strlen (str);
5366
babe1480
JB
5367 /* Skip optional leading __[0-9]+. */
5368
4c4b4cd2
PH
5369 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5370 {
babe1480
JB
5371 str += 3;
5372 while (isdigit (str[0]))
5373 str += 1;
4c4b4cd2 5374 }
babe1480
JB
5375
5376 /* [.$][0-9]+ */
4c4b4cd2 5377
babe1480 5378 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5379 {
babe1480 5380 matching = str + 1;
4c4b4cd2
PH
5381 while (isdigit (matching[0]))
5382 matching += 1;
5383 if (matching[0] == '\0')
5384 return 1;
5385 }
5386
5387 /* ___[0-9]+ */
babe1480 5388
4c4b4cd2
PH
5389 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5390 {
5391 matching = str + 3;
5392 while (isdigit (matching[0]))
5393 matching += 1;
5394 if (matching[0] == '\0')
5395 return 1;
5396 }
5397
9ac7f98e
JB
5398 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5399
5400 if (strcmp (str, "TKB") == 0)
5401 return 1;
5402
529cad9c
PH
5403#if 0
5404 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
5405 with a N at the end. Unfortunately, the compiler uses the same
5406 convention for other internal types it creates. So treating
529cad9c 5407 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
5408 some regressions. For instance, consider the case of an enumerated
5409 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
5410 name ends with N.
5411 Having a single character like this as a suffix carrying some
0963b4bd 5412 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
5413 to be something like "_N" instead. In the meantime, do not do
5414 the following check. */
5415 /* Protected Object Subprograms */
5416 if (len == 1 && str [0] == 'N')
5417 return 1;
5418#endif
5419
5420 /* _E[0-9]+[bs]$ */
5421 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5422 {
5423 matching = str + 3;
5424 while (isdigit (matching[0]))
5425 matching += 1;
5426 if ((matching[0] == 'b' || matching[0] == 's')
5427 && matching [1] == '\0')
5428 return 1;
5429 }
5430
4c4b4cd2
PH
5431 /* ??? We should not modify STR directly, as we are doing below. This
5432 is fine in this case, but may become problematic later if we find
5433 that this alternative did not work, and want to try matching
5434 another one from the begining of STR. Since we modified it, we
5435 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
5436 if (str[0] == 'X')
5437 {
5438 str += 1;
d2e4a39e 5439 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
5440 {
5441 if (str[0] != 'n' && str[0] != 'b')
5442 return 0;
5443 str += 1;
5444 }
14f9c5c9 5445 }
babe1480 5446
14f9c5c9
AS
5447 if (str[0] == '\000')
5448 return 1;
babe1480 5449
d2e4a39e 5450 if (str[0] == '_')
14f9c5c9
AS
5451 {
5452 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 5453 return 0;
d2e4a39e 5454 if (str[2] == '_')
4c4b4cd2 5455 {
61ee279c
PH
5456 if (strcmp (str + 3, "JM") == 0)
5457 return 1;
5458 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5459 the LJM suffix in favor of the JM one. But we will
5460 still accept LJM as a valid suffix for a reasonable
5461 amount of time, just to allow ourselves to debug programs
5462 compiled using an older version of GNAT. */
4c4b4cd2
PH
5463 if (strcmp (str + 3, "LJM") == 0)
5464 return 1;
5465 if (str[3] != 'X')
5466 return 0;
1265e4aa
JB
5467 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5468 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
5469 return 1;
5470 if (str[4] == 'R' && str[5] != 'T')
5471 return 1;
5472 return 0;
5473 }
5474 if (!isdigit (str[2]))
5475 return 0;
5476 for (k = 3; str[k] != '\0'; k += 1)
5477 if (!isdigit (str[k]) && str[k] != '_')
5478 return 0;
14f9c5c9
AS
5479 return 1;
5480 }
4c4b4cd2 5481 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 5482 {
4c4b4cd2
PH
5483 for (k = 2; str[k] != '\0'; k += 1)
5484 if (!isdigit (str[k]) && str[k] != '_')
5485 return 0;
14f9c5c9
AS
5486 return 1;
5487 }
5488 return 0;
5489}
d2e4a39e 5490
aeb5907d
JB
5491/* Return non-zero if the string starting at NAME and ending before
5492 NAME_END contains no capital letters. */
529cad9c
PH
5493
5494static int
5495is_valid_name_for_wild_match (const char *name0)
5496{
5497 const char *decoded_name = ada_decode (name0);
5498 int i;
5499
5823c3ef
JB
5500 /* If the decoded name starts with an angle bracket, it means that
5501 NAME0 does not follow the GNAT encoding format. It should then
5502 not be allowed as a possible wild match. */
5503 if (decoded_name[0] == '<')
5504 return 0;
5505
529cad9c
PH
5506 for (i=0; decoded_name[i] != '\0'; i++)
5507 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5508 return 0;
5509
5510 return 1;
5511}
5512
73589123
PH
5513/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5514 that could start a simple name. Assumes that *NAMEP points into
5515 the string beginning at NAME0. */
4c4b4cd2 5516
14f9c5c9 5517static int
73589123 5518advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 5519{
73589123 5520 const char *name = *namep;
5b4ee69b 5521
5823c3ef 5522 while (1)
14f9c5c9 5523 {
aa27d0b3 5524 int t0, t1;
73589123
PH
5525
5526 t0 = *name;
5527 if (t0 == '_')
5528 {
5529 t1 = name[1];
5530 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5531 {
5532 name += 1;
5533 if (name == name0 + 5 && strncmp (name0, "_ada", 4) == 0)
5534 break;
5535 else
5536 name += 1;
5537 }
aa27d0b3
JB
5538 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5539 || name[2] == target0))
73589123
PH
5540 {
5541 name += 2;
5542 break;
5543 }
5544 else
5545 return 0;
5546 }
5547 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5548 name += 1;
5549 else
5823c3ef 5550 return 0;
73589123
PH
5551 }
5552
5553 *namep = name;
5554 return 1;
5555}
5556
5557/* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5558 informational suffixes of NAME (i.e., for which is_name_suffix is
5559 true). Assumes that PATN is a lower-cased Ada simple name. */
5560
5561static int
5562wild_match (const char *name, const char *patn)
5563{
22e048c9 5564 const char *p;
73589123
PH
5565 const char *name0 = name;
5566
5567 while (1)
5568 {
5569 const char *match = name;
5570
5571 if (*name == *patn)
5572 {
5573 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5574 if (*p != *name)
5575 break;
5576 if (*p == '\0' && is_name_suffix (name))
5577 return match != name0 && !is_valid_name_for_wild_match (name0);
5578
5579 if (name[-1] == '_')
5580 name -= 1;
5581 }
5582 if (!advance_wild_match (&name, name0, *patn))
5583 return 1;
96d887e8 5584 }
96d887e8
PH
5585}
5586
40658b94
PH
5587/* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
5588 informational suffix. */
5589
c4d840bd
PH
5590static int
5591full_match (const char *sym_name, const char *search_name)
5592{
40658b94 5593 return !match_name (sym_name, search_name, 0);
c4d840bd
PH
5594}
5595
5596
96d887e8
PH
5597/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5598 vector *defn_symbols, updating the list of symbols in OBSTACKP
0963b4bd 5599 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4eeaa230 5600 OBJFILE is the section containing BLOCK. */
96d887e8
PH
5601
5602static void
5603ada_add_block_symbols (struct obstack *obstackp,
76a01679 5604 struct block *block, const char *name,
96d887e8 5605 domain_enum domain, struct objfile *objfile,
2570f2b7 5606 int wild)
96d887e8 5607{
8157b174 5608 struct block_iterator iter;
96d887e8
PH
5609 int name_len = strlen (name);
5610 /* A matching argument symbol, if any. */
5611 struct symbol *arg_sym;
5612 /* Set true when we find a matching non-argument symbol. */
5613 int found_sym;
5614 struct symbol *sym;
5615
5616 arg_sym = NULL;
5617 found_sym = 0;
5618 if (wild)
5619 {
8157b174
TT
5620 for (sym = block_iter_match_first (block, name, wild_match, &iter);
5621 sym != NULL; sym = block_iter_match_next (name, wild_match, &iter))
76a01679 5622 {
5eeb2539
AR
5623 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5624 SYMBOL_DOMAIN (sym), domain)
73589123 5625 && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0)
76a01679 5626 {
2a2d4dc3
AS
5627 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5628 continue;
5629 else if (SYMBOL_IS_ARGUMENT (sym))
5630 arg_sym = sym;
5631 else
5632 {
76a01679
JB
5633 found_sym = 1;
5634 add_defn_to_vec (obstackp,
5635 fixup_symbol_section (sym, objfile),
2570f2b7 5636 block);
76a01679
JB
5637 }
5638 }
5639 }
96d887e8
PH
5640 }
5641 else
5642 {
8157b174
TT
5643 for (sym = block_iter_match_first (block, name, full_match, &iter);
5644 sym != NULL; sym = block_iter_match_next (name, full_match, &iter))
76a01679 5645 {
5eeb2539
AR
5646 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5647 SYMBOL_DOMAIN (sym), domain))
76a01679 5648 {
c4d840bd
PH
5649 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5650 {
5651 if (SYMBOL_IS_ARGUMENT (sym))
5652 arg_sym = sym;
5653 else
2a2d4dc3 5654 {
c4d840bd
PH
5655 found_sym = 1;
5656 add_defn_to_vec (obstackp,
5657 fixup_symbol_section (sym, objfile),
5658 block);
2a2d4dc3 5659 }
c4d840bd 5660 }
76a01679
JB
5661 }
5662 }
96d887e8
PH
5663 }
5664
5665 if (!found_sym && arg_sym != NULL)
5666 {
76a01679
JB
5667 add_defn_to_vec (obstackp,
5668 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5669 block);
96d887e8
PH
5670 }
5671
5672 if (!wild)
5673 {
5674 arg_sym = NULL;
5675 found_sym = 0;
5676
5677 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 5678 {
5eeb2539
AR
5679 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5680 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
5681 {
5682 int cmp;
5683
5684 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5685 if (cmp == 0)
5686 {
5687 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5688 if (cmp == 0)
5689 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5690 name_len);
5691 }
5692
5693 if (cmp == 0
5694 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5695 {
2a2d4dc3
AS
5696 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5697 {
5698 if (SYMBOL_IS_ARGUMENT (sym))
5699 arg_sym = sym;
5700 else
5701 {
5702 found_sym = 1;
5703 add_defn_to_vec (obstackp,
5704 fixup_symbol_section (sym, objfile),
5705 block);
5706 }
5707 }
76a01679
JB
5708 }
5709 }
76a01679 5710 }
96d887e8
PH
5711
5712 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5713 They aren't parameters, right? */
5714 if (!found_sym && arg_sym != NULL)
5715 {
5716 add_defn_to_vec (obstackp,
76a01679 5717 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5718 block);
96d887e8
PH
5719 }
5720 }
5721}
5722\f
41d27058
JB
5723
5724 /* Symbol Completion */
5725
5726/* If SYM_NAME is a completion candidate for TEXT, return this symbol
5727 name in a form that's appropriate for the completion. The result
5728 does not need to be deallocated, but is only good until the next call.
5729
5730 TEXT_LEN is equal to the length of TEXT.
e701b3c0 5731 Perform a wild match if WILD_MATCH_P is set.
6ea35997 5732 ENCODED_P should be set if TEXT represents the start of a symbol name
41d27058
JB
5733 in its encoded form. */
5734
5735static const char *
5736symbol_completion_match (const char *sym_name,
5737 const char *text, int text_len,
6ea35997 5738 int wild_match_p, int encoded_p)
41d27058 5739{
41d27058
JB
5740 const int verbatim_match = (text[0] == '<');
5741 int match = 0;
5742
5743 if (verbatim_match)
5744 {
5745 /* Strip the leading angle bracket. */
5746 text = text + 1;
5747 text_len--;
5748 }
5749
5750 /* First, test against the fully qualified name of the symbol. */
5751
5752 if (strncmp (sym_name, text, text_len) == 0)
5753 match = 1;
5754
6ea35997 5755 if (match && !encoded_p)
41d27058
JB
5756 {
5757 /* One needed check before declaring a positive match is to verify
5758 that iff we are doing a verbatim match, the decoded version
5759 of the symbol name starts with '<'. Otherwise, this symbol name
5760 is not a suitable completion. */
5761 const char *sym_name_copy = sym_name;
5762 int has_angle_bracket;
5763
5764 sym_name = ada_decode (sym_name);
5765 has_angle_bracket = (sym_name[0] == '<');
5766 match = (has_angle_bracket == verbatim_match);
5767 sym_name = sym_name_copy;
5768 }
5769
5770 if (match && !verbatim_match)
5771 {
5772 /* When doing non-verbatim match, another check that needs to
5773 be done is to verify that the potentially matching symbol name
5774 does not include capital letters, because the ada-mode would
5775 not be able to understand these symbol names without the
5776 angle bracket notation. */
5777 const char *tmp;
5778
5779 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5780 if (*tmp != '\0')
5781 match = 0;
5782 }
5783
5784 /* Second: Try wild matching... */
5785
e701b3c0 5786 if (!match && wild_match_p)
41d27058
JB
5787 {
5788 /* Since we are doing wild matching, this means that TEXT
5789 may represent an unqualified symbol name. We therefore must
5790 also compare TEXT against the unqualified name of the symbol. */
5791 sym_name = ada_unqualified_name (ada_decode (sym_name));
5792
5793 if (strncmp (sym_name, text, text_len) == 0)
5794 match = 1;
5795 }
5796
5797 /* Finally: If we found a mach, prepare the result to return. */
5798
5799 if (!match)
5800 return NULL;
5801
5802 if (verbatim_match)
5803 sym_name = add_angle_brackets (sym_name);
5804
6ea35997 5805 if (!encoded_p)
41d27058
JB
5806 sym_name = ada_decode (sym_name);
5807
5808 return sym_name;
5809}
5810
5811/* A companion function to ada_make_symbol_completion_list().
5812 Check if SYM_NAME represents a symbol which name would be suitable
5813 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5814 it is appended at the end of the given string vector SV.
5815
5816 ORIG_TEXT is the string original string from the user command
5817 that needs to be completed. WORD is the entire command on which
5818 completion should be performed. These two parameters are used to
5819 determine which part of the symbol name should be added to the
5820 completion vector.
c0af1706 5821 if WILD_MATCH_P is set, then wild matching is performed.
cb8e9b97 5822 ENCODED_P should be set if TEXT represents a symbol name in its
41d27058
JB
5823 encoded formed (in which case the completion should also be
5824 encoded). */
5825
5826static void
d6565258 5827symbol_completion_add (VEC(char_ptr) **sv,
41d27058
JB
5828 const char *sym_name,
5829 const char *text, int text_len,
5830 const char *orig_text, const char *word,
cb8e9b97 5831 int wild_match_p, int encoded_p)
41d27058
JB
5832{
5833 const char *match = symbol_completion_match (sym_name, text, text_len,
cb8e9b97 5834 wild_match_p, encoded_p);
41d27058
JB
5835 char *completion;
5836
5837 if (match == NULL)
5838 return;
5839
5840 /* We found a match, so add the appropriate completion to the given
5841 string vector. */
5842
5843 if (word == orig_text)
5844 {
5845 completion = xmalloc (strlen (match) + 5);
5846 strcpy (completion, match);
5847 }
5848 else if (word > orig_text)
5849 {
5850 /* Return some portion of sym_name. */
5851 completion = xmalloc (strlen (match) + 5);
5852 strcpy (completion, match + (word - orig_text));
5853 }
5854 else
5855 {
5856 /* Return some of ORIG_TEXT plus sym_name. */
5857 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
5858 strncpy (completion, word, orig_text - word);
5859 completion[orig_text - word] = '\0';
5860 strcat (completion, match);
5861 }
5862
d6565258 5863 VEC_safe_push (char_ptr, *sv, completion);
41d27058
JB
5864}
5865
ccefe4c4 5866/* An object of this type is passed as the user_data argument to the
7b08b9eb 5867 expand_partial_symbol_names method. */
ccefe4c4
TT
5868struct add_partial_datum
5869{
5870 VEC(char_ptr) **completions;
6f937416 5871 const char *text;
ccefe4c4 5872 int text_len;
6f937416
PA
5873 const char *text0;
5874 const char *word;
ccefe4c4
TT
5875 int wild_match;
5876 int encoded;
5877};
5878
7b08b9eb
JK
5879/* A callback for expand_partial_symbol_names. */
5880static int
e078317b 5881ada_expand_partial_symbol_name (const char *name, void *user_data)
ccefe4c4
TT
5882{
5883 struct add_partial_datum *data = user_data;
7b08b9eb
JK
5884
5885 return symbol_completion_match (name, data->text, data->text_len,
5886 data->wild_match, data->encoded) != NULL;
ccefe4c4
TT
5887}
5888
49c4e619
TT
5889/* Return a list of possible symbol names completing TEXT0. WORD is
5890 the entire command on which completion is made. */
41d27058 5891
49c4e619 5892static VEC (char_ptr) *
6f937416
PA
5893ada_make_symbol_completion_list (const char *text0, const char *word,
5894 enum type_code code)
41d27058
JB
5895{
5896 char *text;
5897 int text_len;
b1ed564a
JB
5898 int wild_match_p;
5899 int encoded_p;
2ba95b9b 5900 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
41d27058
JB
5901 struct symbol *sym;
5902 struct symtab *s;
41d27058
JB
5903 struct minimal_symbol *msymbol;
5904 struct objfile *objfile;
5905 struct block *b, *surrounding_static_block = 0;
5906 int i;
8157b174 5907 struct block_iterator iter;
b8fea896 5908 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
41d27058 5909
2f68a895
TT
5910 gdb_assert (code == TYPE_CODE_UNDEF);
5911
41d27058
JB
5912 if (text0[0] == '<')
5913 {
5914 text = xstrdup (text0);
5915 make_cleanup (xfree, text);
5916 text_len = strlen (text);
b1ed564a
JB
5917 wild_match_p = 0;
5918 encoded_p = 1;
41d27058
JB
5919 }
5920 else
5921 {
5922 text = xstrdup (ada_encode (text0));
5923 make_cleanup (xfree, text);
5924 text_len = strlen (text);
5925 for (i = 0; i < text_len; i++)
5926 text[i] = tolower (text[i]);
5927
b1ed564a 5928 encoded_p = (strstr (text0, "__") != NULL);
41d27058
JB
5929 /* If the name contains a ".", then the user is entering a fully
5930 qualified entity name, and the match must not be done in wild
5931 mode. Similarly, if the user wants to complete what looks like
5932 an encoded name, the match must not be done in wild mode. */
b1ed564a 5933 wild_match_p = (strchr (text0, '.') == NULL && !encoded_p);
41d27058
JB
5934 }
5935
5936 /* First, look at the partial symtab symbols. */
41d27058 5937 {
ccefe4c4
TT
5938 struct add_partial_datum data;
5939
5940 data.completions = &completions;
5941 data.text = text;
5942 data.text_len = text_len;
5943 data.text0 = text0;
5944 data.word = word;
b1ed564a
JB
5945 data.wild_match = wild_match_p;
5946 data.encoded = encoded_p;
7b08b9eb 5947 expand_partial_symbol_names (ada_expand_partial_symbol_name, &data);
41d27058
JB
5948 }
5949
5950 /* At this point scan through the misc symbol vectors and add each
5951 symbol you find to the list. Eventually we want to ignore
5952 anything that isn't a text symbol (everything else will be
5953 handled by the psymtab code above). */
5954
5955 ALL_MSYMBOLS (objfile, msymbol)
5956 {
5957 QUIT;
d6565258 5958 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol),
b1ed564a
JB
5959 text, text_len, text0, word, wild_match_p,
5960 encoded_p);
41d27058
JB
5961 }
5962
5963 /* Search upwards from currently selected frame (so that we can
5964 complete on local vars. */
5965
5966 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
5967 {
5968 if (!BLOCK_SUPERBLOCK (b))
5969 surrounding_static_block = b; /* For elmin of dups */
5970
5971 ALL_BLOCK_SYMBOLS (b, iter, sym)
5972 {
d6565258 5973 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 5974 text, text_len, text0, word,
b1ed564a 5975 wild_match_p, encoded_p);
41d27058
JB
5976 }
5977 }
5978
5979 /* Go through the symtabs and check the externs and statics for
5980 symbols which match. */
5981
5982 ALL_SYMTABS (objfile, s)
5983 {
5984 QUIT;
5985 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
5986 ALL_BLOCK_SYMBOLS (b, iter, sym)
5987 {
d6565258 5988 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 5989 text, text_len, text0, word,
b1ed564a 5990 wild_match_p, encoded_p);
41d27058
JB
5991 }
5992 }
5993
5994 ALL_SYMTABS (objfile, s)
5995 {
5996 QUIT;
5997 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
5998 /* Don't do this block twice. */
5999 if (b == surrounding_static_block)
6000 continue;
6001 ALL_BLOCK_SYMBOLS (b, iter, sym)
6002 {
d6565258 6003 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6004 text, text_len, text0, word,
b1ed564a 6005 wild_match_p, encoded_p);
41d27058
JB
6006 }
6007 }
6008
b8fea896 6009 do_cleanups (old_chain);
49c4e619 6010 return completions;
41d27058
JB
6011}
6012
963a6417 6013 /* Field Access */
96d887e8 6014
73fb9985
JB
6015/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6016 for tagged types. */
6017
6018static int
6019ada_is_dispatch_table_ptr_type (struct type *type)
6020{
0d5cff50 6021 const char *name;
73fb9985
JB
6022
6023 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6024 return 0;
6025
6026 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6027 if (name == NULL)
6028 return 0;
6029
6030 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6031}
6032
ac4a2da4
JG
6033/* Return non-zero if TYPE is an interface tag. */
6034
6035static int
6036ada_is_interface_tag (struct type *type)
6037{
6038 const char *name = TYPE_NAME (type);
6039
6040 if (name == NULL)
6041 return 0;
6042
6043 return (strcmp (name, "ada__tags__interface_tag") == 0);
6044}
6045
963a6417
PH
6046/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6047 to be invisible to users. */
96d887e8 6048
963a6417
PH
6049int
6050ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6051{
963a6417
PH
6052 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6053 return 1;
ffde82bf 6054
73fb9985
JB
6055 /* Check the name of that field. */
6056 {
6057 const char *name = TYPE_FIELD_NAME (type, field_num);
6058
6059 /* Anonymous field names should not be printed.
6060 brobecker/2007-02-20: I don't think this can actually happen
6061 but we don't want to print the value of annonymous fields anyway. */
6062 if (name == NULL)
6063 return 1;
6064
ffde82bf
JB
6065 /* Normally, fields whose name start with an underscore ("_")
6066 are fields that have been internally generated by the compiler,
6067 and thus should not be printed. The "_parent" field is special,
6068 however: This is a field internally generated by the compiler
6069 for tagged types, and it contains the components inherited from
6070 the parent type. This field should not be printed as is, but
6071 should not be ignored either. */
73fb9985
JB
6072 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
6073 return 1;
6074 }
6075
ac4a2da4
JG
6076 /* If this is the dispatch table of a tagged type or an interface tag,
6077 then ignore. */
73fb9985 6078 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6079 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6080 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6081 return 1;
6082
6083 /* Not a special field, so it should not be ignored. */
6084 return 0;
963a6417 6085}
96d887e8 6086
963a6417 6087/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6088 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6089
963a6417
PH
6090int
6091ada_is_tagged_type (struct type *type, int refok)
6092{
6093 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
6094}
96d887e8 6095
963a6417 6096/* True iff TYPE represents the type of X'Tag */
96d887e8 6097
963a6417
PH
6098int
6099ada_is_tag_type (struct type *type)
6100{
6101 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6102 return 0;
6103 else
96d887e8 6104 {
963a6417 6105 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6106
963a6417
PH
6107 return (name != NULL
6108 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6109 }
96d887e8
PH
6110}
6111
963a6417 6112/* The type of the tag on VAL. */
76a01679 6113
963a6417
PH
6114struct type *
6115ada_tag_type (struct value *val)
96d887e8 6116{
df407dfe 6117 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
963a6417 6118}
96d887e8 6119
b50d69b5
JG
6120/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6121 retired at Ada 05). */
6122
6123static int
6124is_ada95_tag (struct value *tag)
6125{
6126 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6127}
6128
963a6417 6129/* The value of the tag on VAL. */
96d887e8 6130
963a6417
PH
6131struct value *
6132ada_value_tag (struct value *val)
6133{
03ee6b2e 6134 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6135}
6136
963a6417
PH
6137/* The value of the tag on the object of type TYPE whose contents are
6138 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6139 ADDRESS. */
96d887e8 6140
963a6417 6141static struct value *
10a2c479 6142value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6143 const gdb_byte *valaddr,
963a6417 6144 CORE_ADDR address)
96d887e8 6145{
b5385fc0 6146 int tag_byte_offset;
963a6417 6147 struct type *tag_type;
5b4ee69b 6148
963a6417 6149 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6150 NULL, NULL, NULL))
96d887e8 6151 {
fc1a4b47 6152 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6153 ? NULL
6154 : valaddr + tag_byte_offset);
963a6417 6155 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6156
963a6417 6157 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6158 }
963a6417
PH
6159 return NULL;
6160}
96d887e8 6161
963a6417
PH
6162static struct type *
6163type_from_tag (struct value *tag)
6164{
6165 const char *type_name = ada_tag_name (tag);
5b4ee69b 6166
963a6417
PH
6167 if (type_name != NULL)
6168 return ada_find_any_type (ada_encode (type_name));
6169 return NULL;
6170}
96d887e8 6171
b50d69b5
JG
6172/* Given a value OBJ of a tagged type, return a value of this
6173 type at the base address of the object. The base address, as
6174 defined in Ada.Tags, it is the address of the primary tag of
6175 the object, and therefore where the field values of its full
6176 view can be fetched. */
6177
6178struct value *
6179ada_tag_value_at_base_address (struct value *obj)
6180{
6181 volatile struct gdb_exception e;
6182 struct value *val;
6183 LONGEST offset_to_top = 0;
6184 struct type *ptr_type, *obj_type;
6185 struct value *tag;
6186 CORE_ADDR base_address;
6187
6188 obj_type = value_type (obj);
6189
6190 /* It is the responsability of the caller to deref pointers. */
6191
6192 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6193 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6194 return obj;
6195
6196 tag = ada_value_tag (obj);
6197 if (!tag)
6198 return obj;
6199
6200 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6201
6202 if (is_ada95_tag (tag))
6203 return obj;
6204
6205 ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
6206 ptr_type = lookup_pointer_type (ptr_type);
6207 val = value_cast (ptr_type, tag);
6208 if (!val)
6209 return obj;
6210
6211 /* It is perfectly possible that an exception be raised while
6212 trying to determine the base address, just like for the tag;
6213 see ada_tag_name for more details. We do not print the error
6214 message for the same reason. */
6215
6216 TRY_CATCH (e, RETURN_MASK_ERROR)
6217 {
6218 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6219 }
6220
6221 if (e.reason < 0)
6222 return obj;
6223
6224 /* If offset is null, nothing to do. */
6225
6226 if (offset_to_top == 0)
6227 return obj;
6228
6229 /* -1 is a special case in Ada.Tags; however, what should be done
6230 is not quite clear from the documentation. So do nothing for
6231 now. */
6232
6233 if (offset_to_top == -1)
6234 return obj;
6235
6236 base_address = value_address (obj) - offset_to_top;
6237 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6238
6239 /* Make sure that we have a proper tag at the new address.
6240 Otherwise, offset_to_top is bogus (which can happen when
6241 the object is not initialized yet). */
6242
6243 if (!tag)
6244 return obj;
6245
6246 obj_type = type_from_tag (tag);
6247
6248 if (!obj_type)
6249 return obj;
6250
6251 return value_from_contents_and_address (obj_type, NULL, base_address);
6252}
6253
1b611343
JB
6254/* Return the "ada__tags__type_specific_data" type. */
6255
6256static struct type *
6257ada_get_tsd_type (struct inferior *inf)
963a6417 6258{
1b611343 6259 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6260
1b611343
JB
6261 if (data->tsd_type == 0)
6262 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6263 return data->tsd_type;
6264}
529cad9c 6265
1b611343
JB
6266/* Return the TSD (type-specific data) associated to the given TAG.
6267 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6268
1b611343 6269 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6270
1b611343
JB
6271static struct value *
6272ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6273{
4c4b4cd2 6274 struct value *val;
1b611343 6275 struct type *type;
5b4ee69b 6276
1b611343
JB
6277 /* First option: The TSD is simply stored as a field of our TAG.
6278 Only older versions of GNAT would use this format, but we have
6279 to test it first, because there are no visible markers for
6280 the current approach except the absence of that field. */
529cad9c 6281
1b611343
JB
6282 val = ada_value_struct_elt (tag, "tsd", 1);
6283 if (val)
6284 return val;
e802dbe0 6285
1b611343
JB
6286 /* Try the second representation for the dispatch table (in which
6287 there is no explicit 'tsd' field in the referent of the tag pointer,
6288 and instead the tsd pointer is stored just before the dispatch
6289 table. */
e802dbe0 6290
1b611343
JB
6291 type = ada_get_tsd_type (current_inferior());
6292 if (type == NULL)
6293 return NULL;
6294 type = lookup_pointer_type (lookup_pointer_type (type));
6295 val = value_cast (type, tag);
6296 if (val == NULL)
6297 return NULL;
6298 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6299}
6300
1b611343
JB
6301/* Given the TSD of a tag (type-specific data), return a string
6302 containing the name of the associated type.
6303
6304 The returned value is good until the next call. May return NULL
6305 if we are unable to determine the tag name. */
6306
6307static char *
6308ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6309{
529cad9c
PH
6310 static char name[1024];
6311 char *p;
1b611343 6312 struct value *val;
529cad9c 6313
1b611343 6314 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6315 if (val == NULL)
1b611343 6316 return NULL;
4c4b4cd2
PH
6317 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6318 for (p = name; *p != '\0'; p += 1)
6319 if (isalpha (*p))
6320 *p = tolower (*p);
1b611343 6321 return name;
4c4b4cd2
PH
6322}
6323
6324/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6325 a C string.
6326
6327 Return NULL if the TAG is not an Ada tag, or if we were unable to
6328 determine the name of that tag. The result is good until the next
6329 call. */
4c4b4cd2
PH
6330
6331const char *
6332ada_tag_name (struct value *tag)
6333{
1b611343
JB
6334 volatile struct gdb_exception e;
6335 char *name = NULL;
5b4ee69b 6336
df407dfe 6337 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6338 return NULL;
1b611343
JB
6339
6340 /* It is perfectly possible that an exception be raised while trying
6341 to determine the TAG's name, even under normal circumstances:
6342 The associated variable may be uninitialized or corrupted, for
6343 instance. We do not let any exception propagate past this point.
6344 instead we return NULL.
6345
6346 We also do not print the error message either (which often is very
6347 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6348 the caller print a more meaningful message if necessary. */
6349 TRY_CATCH (e, RETURN_MASK_ERROR)
6350 {
6351 struct value *tsd = ada_get_tsd_from_tag (tag);
6352
6353 if (tsd != NULL)
6354 name = ada_tag_name_from_tsd (tsd);
6355 }
6356
6357 return name;
4c4b4cd2
PH
6358}
6359
6360/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6361
d2e4a39e 6362struct type *
ebf56fd3 6363ada_parent_type (struct type *type)
14f9c5c9
AS
6364{
6365 int i;
6366
61ee279c 6367 type = ada_check_typedef (type);
14f9c5c9
AS
6368
6369 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6370 return NULL;
6371
6372 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6373 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6374 {
6375 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6376
6377 /* If the _parent field is a pointer, then dereference it. */
6378 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6379 parent_type = TYPE_TARGET_TYPE (parent_type);
6380 /* If there is a parallel XVS type, get the actual base type. */
6381 parent_type = ada_get_base_type (parent_type);
6382
6383 return ada_check_typedef (parent_type);
6384 }
14f9c5c9
AS
6385
6386 return NULL;
6387}
6388
4c4b4cd2
PH
6389/* True iff field number FIELD_NUM of structure type TYPE contains the
6390 parent-type (inherited) fields of a derived type. Assumes TYPE is
6391 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6392
6393int
ebf56fd3 6394ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6395{
61ee279c 6396 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6397
4c4b4cd2
PH
6398 return (name != NULL
6399 && (strncmp (name, "PARENT", 6) == 0
6400 || strncmp (name, "_parent", 7) == 0));
14f9c5c9
AS
6401}
6402
4c4b4cd2 6403/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6404 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6405 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6406 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6407 structures. */
14f9c5c9
AS
6408
6409int
ebf56fd3 6410ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6411{
d2e4a39e 6412 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6413
d2e4a39e 6414 return (name != NULL
4c4b4cd2
PH
6415 && (strncmp (name, "PARENT", 6) == 0
6416 || strcmp (name, "REP") == 0
6417 || strncmp (name, "_parent", 7) == 0
6418 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6419}
6420
4c4b4cd2
PH
6421/* True iff field number FIELD_NUM of structure or union type TYPE
6422 is a variant wrapper. Assumes TYPE is a structure type with at least
6423 FIELD_NUM+1 fields. */
14f9c5c9
AS
6424
6425int
ebf56fd3 6426ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6427{
d2e4a39e 6428 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6429
14f9c5c9 6430 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6431 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6432 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6433 == TYPE_CODE_UNION)));
14f9c5c9
AS
6434}
6435
6436/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6437 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6438 returns the type of the controlling discriminant for the variant.
6439 May return NULL if the type could not be found. */
14f9c5c9 6440
d2e4a39e 6441struct type *
ebf56fd3 6442ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6443{
d2e4a39e 6444 char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6445
7c964f07 6446 return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
14f9c5c9
AS
6447}
6448
4c4b4cd2 6449/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6450 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6451 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6452
6453int
ebf56fd3 6454ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6455{
d2e4a39e 6456 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6457
14f9c5c9
AS
6458 return (name != NULL && name[0] == 'O');
6459}
6460
6461/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
6462 returns the name of the discriminant controlling the variant.
6463 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 6464
d2e4a39e 6465char *
ebf56fd3 6466ada_variant_discrim_name (struct type *type0)
14f9c5c9 6467{
d2e4a39e 6468 static char *result = NULL;
14f9c5c9 6469 static size_t result_len = 0;
d2e4a39e
AS
6470 struct type *type;
6471 const char *name;
6472 const char *discrim_end;
6473 const char *discrim_start;
14f9c5c9
AS
6474
6475 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6476 type = TYPE_TARGET_TYPE (type0);
6477 else
6478 type = type0;
6479
6480 name = ada_type_name (type);
6481
6482 if (name == NULL || name[0] == '\000')
6483 return "";
6484
6485 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6486 discrim_end -= 1)
6487 {
4c4b4cd2
PH
6488 if (strncmp (discrim_end, "___XVN", 6) == 0)
6489 break;
14f9c5c9
AS
6490 }
6491 if (discrim_end == name)
6492 return "";
6493
d2e4a39e 6494 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
6495 discrim_start -= 1)
6496 {
d2e4a39e 6497 if (discrim_start == name + 1)
4c4b4cd2 6498 return "";
76a01679 6499 if ((discrim_start > name + 3
4c4b4cd2
PH
6500 && strncmp (discrim_start - 3, "___", 3) == 0)
6501 || discrim_start[-1] == '.')
6502 break;
14f9c5c9
AS
6503 }
6504
6505 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6506 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 6507 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
6508 return result;
6509}
6510
4c4b4cd2
PH
6511/* Scan STR for a subtype-encoded number, beginning at position K.
6512 Put the position of the character just past the number scanned in
6513 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6514 Return 1 if there was a valid number at the given position, and 0
6515 otherwise. A "subtype-encoded" number consists of the absolute value
6516 in decimal, followed by the letter 'm' to indicate a negative number.
6517 Assumes 0m does not occur. */
14f9c5c9
AS
6518
6519int
d2e4a39e 6520ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
6521{
6522 ULONGEST RU;
6523
d2e4a39e 6524 if (!isdigit (str[k]))
14f9c5c9
AS
6525 return 0;
6526
4c4b4cd2 6527 /* Do it the hard way so as not to make any assumption about
14f9c5c9 6528 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 6529 LONGEST. */
14f9c5c9
AS
6530 RU = 0;
6531 while (isdigit (str[k]))
6532 {
d2e4a39e 6533 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
6534 k += 1;
6535 }
6536
d2e4a39e 6537 if (str[k] == 'm')
14f9c5c9
AS
6538 {
6539 if (R != NULL)
4c4b4cd2 6540 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
6541 k += 1;
6542 }
6543 else if (R != NULL)
6544 *R = (LONGEST) RU;
6545
4c4b4cd2 6546 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
6547 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6548 number representable as a LONGEST (although either would probably work
6549 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 6550 above is always equivalent to the negative of RU. */
14f9c5c9
AS
6551
6552 if (new_k != NULL)
6553 *new_k = k;
6554 return 1;
6555}
6556
4c4b4cd2
PH
6557/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6558 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6559 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 6560
d2e4a39e 6561int
ebf56fd3 6562ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 6563{
d2e4a39e 6564 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
6565 int p;
6566
6567 p = 0;
6568 while (1)
6569 {
d2e4a39e 6570 switch (name[p])
4c4b4cd2
PH
6571 {
6572 case '\0':
6573 return 0;
6574 case 'S':
6575 {
6576 LONGEST W;
5b4ee69b 6577
4c4b4cd2
PH
6578 if (!ada_scan_number (name, p + 1, &W, &p))
6579 return 0;
6580 if (val == W)
6581 return 1;
6582 break;
6583 }
6584 case 'R':
6585 {
6586 LONGEST L, U;
5b4ee69b 6587
4c4b4cd2
PH
6588 if (!ada_scan_number (name, p + 1, &L, &p)
6589 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6590 return 0;
6591 if (val >= L && val <= U)
6592 return 1;
6593 break;
6594 }
6595 case 'O':
6596 return 1;
6597 default:
6598 return 0;
6599 }
6600 }
6601}
6602
0963b4bd 6603/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
6604
6605/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6606 ARG_TYPE, extract and return the value of one of its (non-static)
6607 fields. FIELDNO says which field. Differs from value_primitive_field
6608 only in that it can handle packed values of arbitrary type. */
14f9c5c9 6609
4c4b4cd2 6610static struct value *
d2e4a39e 6611ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 6612 struct type *arg_type)
14f9c5c9 6613{
14f9c5c9
AS
6614 struct type *type;
6615
61ee279c 6616 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
6617 type = TYPE_FIELD_TYPE (arg_type, fieldno);
6618
4c4b4cd2 6619 /* Handle packed fields. */
14f9c5c9
AS
6620
6621 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
6622 {
6623 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6624 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 6625
0fd88904 6626 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
6627 offset + bit_pos / 8,
6628 bit_pos % 8, bit_size, type);
14f9c5c9
AS
6629 }
6630 else
6631 return value_primitive_field (arg1, offset, fieldno, arg_type);
6632}
6633
52ce6436
PH
6634/* Find field with name NAME in object of type TYPE. If found,
6635 set the following for each argument that is non-null:
6636 - *FIELD_TYPE_P to the field's type;
6637 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6638 an object of that type;
6639 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6640 - *BIT_SIZE_P to its size in bits if the field is packed, and
6641 0 otherwise;
6642 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6643 fields up to but not including the desired field, or by the total
6644 number of fields if not found. A NULL value of NAME never
6645 matches; the function just counts visible fields in this case.
6646
0963b4bd 6647 Returns 1 if found, 0 otherwise. */
52ce6436 6648
4c4b4cd2 6649static int
0d5cff50 6650find_struct_field (const char *name, struct type *type, int offset,
76a01679 6651 struct type **field_type_p,
52ce6436
PH
6652 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6653 int *index_p)
4c4b4cd2
PH
6654{
6655 int i;
6656
61ee279c 6657 type = ada_check_typedef (type);
76a01679 6658
52ce6436
PH
6659 if (field_type_p != NULL)
6660 *field_type_p = NULL;
6661 if (byte_offset_p != NULL)
d5d6fca5 6662 *byte_offset_p = 0;
52ce6436
PH
6663 if (bit_offset_p != NULL)
6664 *bit_offset_p = 0;
6665 if (bit_size_p != NULL)
6666 *bit_size_p = 0;
6667
6668 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
6669 {
6670 int bit_pos = TYPE_FIELD_BITPOS (type, i);
6671 int fld_offset = offset + bit_pos / 8;
0d5cff50 6672 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 6673
4c4b4cd2
PH
6674 if (t_field_name == NULL)
6675 continue;
6676
52ce6436 6677 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
6678 {
6679 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 6680
52ce6436
PH
6681 if (field_type_p != NULL)
6682 *field_type_p = TYPE_FIELD_TYPE (type, i);
6683 if (byte_offset_p != NULL)
6684 *byte_offset_p = fld_offset;
6685 if (bit_offset_p != NULL)
6686 *bit_offset_p = bit_pos % 8;
6687 if (bit_size_p != NULL)
6688 *bit_size_p = bit_size;
76a01679
JB
6689 return 1;
6690 }
4c4b4cd2
PH
6691 else if (ada_is_wrapper_field (type, i))
6692 {
52ce6436
PH
6693 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
6694 field_type_p, byte_offset_p, bit_offset_p,
6695 bit_size_p, index_p))
76a01679
JB
6696 return 1;
6697 }
4c4b4cd2
PH
6698 else if (ada_is_variant_part (type, i))
6699 {
52ce6436
PH
6700 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6701 fixed type?? */
4c4b4cd2 6702 int j;
52ce6436
PH
6703 struct type *field_type
6704 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 6705
52ce6436 6706 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6707 {
76a01679
JB
6708 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
6709 fld_offset
6710 + TYPE_FIELD_BITPOS (field_type, j) / 8,
6711 field_type_p, byte_offset_p,
52ce6436 6712 bit_offset_p, bit_size_p, index_p))
76a01679 6713 return 1;
4c4b4cd2
PH
6714 }
6715 }
52ce6436
PH
6716 else if (index_p != NULL)
6717 *index_p += 1;
4c4b4cd2
PH
6718 }
6719 return 0;
6720}
6721
0963b4bd 6722/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 6723
52ce6436
PH
6724static int
6725num_visible_fields (struct type *type)
6726{
6727 int n;
5b4ee69b 6728
52ce6436
PH
6729 n = 0;
6730 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6731 return n;
6732}
14f9c5c9 6733
4c4b4cd2 6734/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
6735 and search in it assuming it has (class) type TYPE.
6736 If found, return value, else return NULL.
6737
4c4b4cd2 6738 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 6739
4c4b4cd2 6740static struct value *
d2e4a39e 6741ada_search_struct_field (char *name, struct value *arg, int offset,
4c4b4cd2 6742 struct type *type)
14f9c5c9
AS
6743{
6744 int i;
14f9c5c9 6745
5b4ee69b 6746 type = ada_check_typedef (type);
52ce6436 6747 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 6748 {
0d5cff50 6749 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
6750
6751 if (t_field_name == NULL)
4c4b4cd2 6752 continue;
14f9c5c9
AS
6753
6754 else if (field_name_match (t_field_name, name))
4c4b4cd2 6755 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
6756
6757 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 6758 {
0963b4bd 6759 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
6760 ada_search_struct_field (name, arg,
6761 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6762 TYPE_FIELD_TYPE (type, i));
5b4ee69b 6763
4c4b4cd2
PH
6764 if (v != NULL)
6765 return v;
6766 }
14f9c5c9
AS
6767
6768 else if (ada_is_variant_part (type, i))
4c4b4cd2 6769 {
0963b4bd 6770 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 6771 int j;
5b4ee69b
MS
6772 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
6773 i));
4c4b4cd2
PH
6774 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6775
52ce6436 6776 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6777 {
0963b4bd
MS
6778 struct value *v = ada_search_struct_field /* Force line
6779 break. */
06d5cf63
JB
6780 (name, arg,
6781 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6782 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 6783
4c4b4cd2
PH
6784 if (v != NULL)
6785 return v;
6786 }
6787 }
14f9c5c9
AS
6788 }
6789 return NULL;
6790}
d2e4a39e 6791
52ce6436
PH
6792static struct value *ada_index_struct_field_1 (int *, struct value *,
6793 int, struct type *);
6794
6795
6796/* Return field #INDEX in ARG, where the index is that returned by
6797 * find_struct_field through its INDEX_P argument. Adjust the address
6798 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 6799 * If found, return value, else return NULL. */
52ce6436
PH
6800
6801static struct value *
6802ada_index_struct_field (int index, struct value *arg, int offset,
6803 struct type *type)
6804{
6805 return ada_index_struct_field_1 (&index, arg, offset, type);
6806}
6807
6808
6809/* Auxiliary function for ada_index_struct_field. Like
6810 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 6811 * *INDEX_P. */
52ce6436
PH
6812
6813static struct value *
6814ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6815 struct type *type)
6816{
6817 int i;
6818 type = ada_check_typedef (type);
6819
6820 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6821 {
6822 if (TYPE_FIELD_NAME (type, i) == NULL)
6823 continue;
6824 else if (ada_is_wrapper_field (type, i))
6825 {
0963b4bd 6826 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
6827 ada_index_struct_field_1 (index_p, arg,
6828 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6829 TYPE_FIELD_TYPE (type, i));
5b4ee69b 6830
52ce6436
PH
6831 if (v != NULL)
6832 return v;
6833 }
6834
6835 else if (ada_is_variant_part (type, i))
6836 {
6837 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 6838 find_struct_field. */
52ce6436
PH
6839 error (_("Cannot assign this kind of variant record"));
6840 }
6841 else if (*index_p == 0)
6842 return ada_value_primitive_field (arg, offset, i, type);
6843 else
6844 *index_p -= 1;
6845 }
6846 return NULL;
6847}
6848
4c4b4cd2
PH
6849/* Given ARG, a value of type (pointer or reference to a)*
6850 structure/union, extract the component named NAME from the ultimate
6851 target structure/union and return it as a value with its
f5938064 6852 appropriate type.
14f9c5c9 6853
4c4b4cd2
PH
6854 The routine searches for NAME among all members of the structure itself
6855 and (recursively) among all members of any wrapper members
14f9c5c9
AS
6856 (e.g., '_parent').
6857
03ee6b2e
PH
6858 If NO_ERR, then simply return NULL in case of error, rather than
6859 calling error. */
14f9c5c9 6860
d2e4a39e 6861struct value *
03ee6b2e 6862ada_value_struct_elt (struct value *arg, char *name, int no_err)
14f9c5c9 6863{
4c4b4cd2 6864 struct type *t, *t1;
d2e4a39e 6865 struct value *v;
14f9c5c9 6866
4c4b4cd2 6867 v = NULL;
df407dfe 6868 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
6869 if (TYPE_CODE (t) == TYPE_CODE_REF)
6870 {
6871 t1 = TYPE_TARGET_TYPE (t);
6872 if (t1 == NULL)
03ee6b2e 6873 goto BadValue;
61ee279c 6874 t1 = ada_check_typedef (t1);
4c4b4cd2 6875 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 6876 {
994b9211 6877 arg = coerce_ref (arg);
76a01679
JB
6878 t = t1;
6879 }
4c4b4cd2 6880 }
14f9c5c9 6881
4c4b4cd2
PH
6882 while (TYPE_CODE (t) == TYPE_CODE_PTR)
6883 {
6884 t1 = TYPE_TARGET_TYPE (t);
6885 if (t1 == NULL)
03ee6b2e 6886 goto BadValue;
61ee279c 6887 t1 = ada_check_typedef (t1);
4c4b4cd2 6888 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
6889 {
6890 arg = value_ind (arg);
6891 t = t1;
6892 }
4c4b4cd2 6893 else
76a01679 6894 break;
4c4b4cd2 6895 }
14f9c5c9 6896
4c4b4cd2 6897 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 6898 goto BadValue;
14f9c5c9 6899
4c4b4cd2
PH
6900 if (t1 == t)
6901 v = ada_search_struct_field (name, arg, 0, t);
6902 else
6903 {
6904 int bit_offset, bit_size, byte_offset;
6905 struct type *field_type;
6906 CORE_ADDR address;
6907
76a01679 6908 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 6909 address = value_address (ada_value_ind (arg));
4c4b4cd2 6910 else
b50d69b5 6911 address = value_address (ada_coerce_ref (arg));
14f9c5c9 6912
1ed6ede0 6913 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
76a01679
JB
6914 if (find_struct_field (name, t1, 0,
6915 &field_type, &byte_offset, &bit_offset,
52ce6436 6916 &bit_size, NULL))
76a01679
JB
6917 {
6918 if (bit_size != 0)
6919 {
714e53ab
PH
6920 if (TYPE_CODE (t) == TYPE_CODE_REF)
6921 arg = ada_coerce_ref (arg);
6922 else
6923 arg = ada_value_ind (arg);
76a01679
JB
6924 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
6925 bit_offset, bit_size,
6926 field_type);
6927 }
6928 else
f5938064 6929 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
6930 }
6931 }
6932
03ee6b2e
PH
6933 if (v != NULL || no_err)
6934 return v;
6935 else
323e0a4a 6936 error (_("There is no member named %s."), name);
14f9c5c9 6937
03ee6b2e
PH
6938 BadValue:
6939 if (no_err)
6940 return NULL;
6941 else
0963b4bd
MS
6942 error (_("Attempt to extract a component of "
6943 "a value that is not a record."));
14f9c5c9
AS
6944}
6945
6946/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
6947 If DISPP is non-null, add its byte displacement from the beginning of a
6948 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
6949 work for packed fields).
6950
6951 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 6952 followed by "___".
14f9c5c9 6953
0963b4bd 6954 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
6955 be a (pointer or reference)+ to a struct or union, and the
6956 ultimate target type will be searched.
14f9c5c9
AS
6957
6958 Looks recursively into variant clauses and parent types.
6959
4c4b4cd2
PH
6960 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6961 TYPE is not a type of the right kind. */
14f9c5c9 6962
4c4b4cd2 6963static struct type *
76a01679
JB
6964ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
6965 int noerr, int *dispp)
14f9c5c9
AS
6966{
6967 int i;
6968
6969 if (name == NULL)
6970 goto BadName;
6971
76a01679 6972 if (refok && type != NULL)
4c4b4cd2
PH
6973 while (1)
6974 {
61ee279c 6975 type = ada_check_typedef (type);
76a01679
JB
6976 if (TYPE_CODE (type) != TYPE_CODE_PTR
6977 && TYPE_CODE (type) != TYPE_CODE_REF)
6978 break;
6979 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 6980 }
14f9c5c9 6981
76a01679 6982 if (type == NULL
1265e4aa
JB
6983 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
6984 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 6985 {
4c4b4cd2 6986 if (noerr)
76a01679 6987 return NULL;
4c4b4cd2 6988 else
76a01679
JB
6989 {
6990 target_terminal_ours ();
6991 gdb_flush (gdb_stdout);
323e0a4a
AC
6992 if (type == NULL)
6993 error (_("Type (null) is not a structure or union type"));
6994 else
6995 {
6996 /* XXX: type_sprint */
6997 fprintf_unfiltered (gdb_stderr, _("Type "));
6998 type_print (type, "", gdb_stderr, -1);
6999 error (_(" is not a structure or union type"));
7000 }
76a01679 7001 }
14f9c5c9
AS
7002 }
7003
7004 type = to_static_fixed_type (type);
7005
7006 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7007 {
0d5cff50 7008 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7009 struct type *t;
7010 int disp;
d2e4a39e 7011
14f9c5c9 7012 if (t_field_name == NULL)
4c4b4cd2 7013 continue;
14f9c5c9
AS
7014
7015 else if (field_name_match (t_field_name, name))
4c4b4cd2
PH
7016 {
7017 if (dispp != NULL)
7018 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
61ee279c 7019 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7020 }
14f9c5c9
AS
7021
7022 else if (ada_is_wrapper_field (type, i))
4c4b4cd2
PH
7023 {
7024 disp = 0;
7025 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7026 0, 1, &disp);
7027 if (t != NULL)
7028 {
7029 if (dispp != NULL)
7030 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7031 return t;
7032 }
7033 }
14f9c5c9
AS
7034
7035 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7036 {
7037 int j;
5b4ee69b
MS
7038 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7039 i));
4c4b4cd2
PH
7040
7041 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7042 {
b1f33ddd
JB
7043 /* FIXME pnh 2008/01/26: We check for a field that is
7044 NOT wrapped in a struct, since the compiler sometimes
7045 generates these for unchecked variant types. Revisit
0963b4bd 7046 if the compiler changes this practice. */
0d5cff50 7047 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
4c4b4cd2 7048 disp = 0;
b1f33ddd
JB
7049 if (v_field_name != NULL
7050 && field_name_match (v_field_name, name))
7051 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
7052 else
0963b4bd
MS
7053 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7054 j),
b1f33ddd
JB
7055 name, 0, 1, &disp);
7056
4c4b4cd2
PH
7057 if (t != NULL)
7058 {
7059 if (dispp != NULL)
7060 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7061 return t;
7062 }
7063 }
7064 }
14f9c5c9
AS
7065
7066 }
7067
7068BadName:
d2e4a39e 7069 if (!noerr)
14f9c5c9
AS
7070 {
7071 target_terminal_ours ();
7072 gdb_flush (gdb_stdout);
323e0a4a
AC
7073 if (name == NULL)
7074 {
7075 /* XXX: type_sprint */
7076 fprintf_unfiltered (gdb_stderr, _("Type "));
7077 type_print (type, "", gdb_stderr, -1);
7078 error (_(" has no component named <null>"));
7079 }
7080 else
7081 {
7082 /* XXX: type_sprint */
7083 fprintf_unfiltered (gdb_stderr, _("Type "));
7084 type_print (type, "", gdb_stderr, -1);
7085 error (_(" has no component named %s"), name);
7086 }
14f9c5c9
AS
7087 }
7088
7089 return NULL;
7090}
7091
b1f33ddd
JB
7092/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7093 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7094 represents an unchecked union (that is, the variant part of a
0963b4bd 7095 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7096
7097static int
7098is_unchecked_variant (struct type *var_type, struct type *outer_type)
7099{
7100 char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7101
b1f33ddd
JB
7102 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
7103 == NULL);
7104}
7105
7106
14f9c5c9
AS
7107/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7108 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7109 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7110 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7111
d2e4a39e 7112int
ebf56fd3 7113ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7114 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7115{
7116 int others_clause;
7117 int i;
d2e4a39e 7118 char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7119 struct value *outer;
7120 struct value *discrim;
14f9c5c9
AS
7121 LONGEST discrim_val;
7122
0c281816
JB
7123 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
7124 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7125 if (discrim == NULL)
14f9c5c9 7126 return -1;
0c281816 7127 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7128
7129 others_clause = -1;
7130 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7131 {
7132 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7133 others_clause = i;
14f9c5c9 7134 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7135 return i;
14f9c5c9
AS
7136 }
7137
7138 return others_clause;
7139}
d2e4a39e 7140\f
14f9c5c9
AS
7141
7142
4c4b4cd2 7143 /* Dynamic-Sized Records */
14f9c5c9
AS
7144
7145/* Strategy: The type ostensibly attached to a value with dynamic size
7146 (i.e., a size that is not statically recorded in the debugging
7147 data) does not accurately reflect the size or layout of the value.
7148 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7149 conventional types that are constructed on the fly. */
14f9c5c9
AS
7150
7151/* There is a subtle and tricky problem here. In general, we cannot
7152 determine the size of dynamic records without its data. However,
7153 the 'struct value' data structure, which GDB uses to represent
7154 quantities in the inferior process (the target), requires the size
7155 of the type at the time of its allocation in order to reserve space
7156 for GDB's internal copy of the data. That's why the
7157 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7158 rather than struct value*s.
14f9c5c9
AS
7159
7160 However, GDB's internal history variables ($1, $2, etc.) are
7161 struct value*s containing internal copies of the data that are not, in
7162 general, the same as the data at their corresponding addresses in
7163 the target. Fortunately, the types we give to these values are all
7164 conventional, fixed-size types (as per the strategy described
7165 above), so that we don't usually have to perform the
7166 'to_fixed_xxx_type' conversions to look at their values.
7167 Unfortunately, there is one exception: if one of the internal
7168 history variables is an array whose elements are unconstrained
7169 records, then we will need to create distinct fixed types for each
7170 element selected. */
7171
7172/* The upshot of all of this is that many routines take a (type, host
7173 address, target address) triple as arguments to represent a value.
7174 The host address, if non-null, is supposed to contain an internal
7175 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7176 target at the target address. */
14f9c5c9
AS
7177
7178/* Assuming that VAL0 represents a pointer value, the result of
7179 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7180 dynamic-sized types. */
14f9c5c9 7181
d2e4a39e
AS
7182struct value *
7183ada_value_ind (struct value *val0)
14f9c5c9 7184{
c48db5ca 7185 struct value *val = value_ind (val0);
5b4ee69b 7186
b50d69b5
JG
7187 if (ada_is_tagged_type (value_type (val), 0))
7188 val = ada_tag_value_at_base_address (val);
7189
4c4b4cd2 7190 return ada_to_fixed_value (val);
14f9c5c9
AS
7191}
7192
7193/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7194 qualifiers on VAL0. */
7195
d2e4a39e
AS
7196static struct value *
7197ada_coerce_ref (struct value *val0)
7198{
df407dfe 7199 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7200 {
7201 struct value *val = val0;
5b4ee69b 7202
994b9211 7203 val = coerce_ref (val);
b50d69b5
JG
7204
7205 if (ada_is_tagged_type (value_type (val), 0))
7206 val = ada_tag_value_at_base_address (val);
7207
4c4b4cd2 7208 return ada_to_fixed_value (val);
d2e4a39e
AS
7209 }
7210 else
14f9c5c9
AS
7211 return val0;
7212}
7213
7214/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7215 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7216
7217static unsigned int
ebf56fd3 7218align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7219{
7220 return (off + alignment - 1) & ~(alignment - 1);
7221}
7222
4c4b4cd2 7223/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7224
7225static unsigned int
ebf56fd3 7226field_alignment (struct type *type, int f)
14f9c5c9 7227{
d2e4a39e 7228 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7229 int len;
14f9c5c9
AS
7230 int align_offset;
7231
64a1bf19
JB
7232 /* The field name should never be null, unless the debugging information
7233 is somehow malformed. In this case, we assume the field does not
7234 require any alignment. */
7235 if (name == NULL)
7236 return 1;
7237
7238 len = strlen (name);
7239
4c4b4cd2
PH
7240 if (!isdigit (name[len - 1]))
7241 return 1;
14f9c5c9 7242
d2e4a39e 7243 if (isdigit (name[len - 2]))
14f9c5c9
AS
7244 align_offset = len - 2;
7245 else
7246 align_offset = len - 1;
7247
4c4b4cd2 7248 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
14f9c5c9
AS
7249 return TARGET_CHAR_BIT;
7250
4c4b4cd2
PH
7251 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7252}
7253
852dff6c 7254/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7255
852dff6c
JB
7256static struct symbol *
7257ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7258{
7259 struct symbol *sym;
7260
7261 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7262 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7263 return sym;
7264
7265 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7266 return sym;
14f9c5c9
AS
7267}
7268
dddfab26
UW
7269/* Find a type named NAME. Ignores ambiguity. This routine will look
7270 solely for types defined by debug info, it will not search the GDB
7271 primitive types. */
4c4b4cd2 7272
852dff6c 7273static struct type *
ebf56fd3 7274ada_find_any_type (const char *name)
14f9c5c9 7275{
852dff6c 7276 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7277
14f9c5c9 7278 if (sym != NULL)
dddfab26 7279 return SYMBOL_TYPE (sym);
14f9c5c9 7280
dddfab26 7281 return NULL;
14f9c5c9
AS
7282}
7283
739593e0
JB
7284/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7285 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7286 symbol, in which case it is returned. Otherwise, this looks for
7287 symbols whose name is that of NAME_SYM suffixed with "___XR".
7288 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7289
7290struct symbol *
270140bd 7291ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7292{
739593e0 7293 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7294 struct symbol *sym;
7295
739593e0
JB
7296 if (strstr (name, "___XR") != NULL)
7297 return name_sym;
7298
aeb5907d
JB
7299 sym = find_old_style_renaming_symbol (name, block);
7300
7301 if (sym != NULL)
7302 return sym;
7303
0963b4bd 7304 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7305 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7306 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7307 return sym;
7308 else
7309 return NULL;
7310}
7311
7312static struct symbol *
270140bd 7313find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 7314{
7f0df278 7315 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
7316 char *rename;
7317
7318 if (function_sym != NULL)
7319 {
7320 /* If the symbol is defined inside a function, NAME is not fully
7321 qualified. This means we need to prepend the function name
7322 as well as adding the ``___XR'' suffix to build the name of
7323 the associated renaming symbol. */
0d5cff50 7324 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
7325 /* Function names sometimes contain suffixes used
7326 for instance to qualify nested subprograms. When building
7327 the XR type name, we need to make sure that this suffix is
7328 not included. So do not include any suffix in the function
7329 name length below. */
69fadcdf 7330 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
7331 const int rename_len = function_name_len + 2 /* "__" */
7332 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 7333
529cad9c 7334 /* Strip the suffix if necessary. */
69fadcdf
JB
7335 ada_remove_trailing_digits (function_name, &function_name_len);
7336 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7337 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 7338
4c4b4cd2
PH
7339 /* Library-level functions are a special case, as GNAT adds
7340 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 7341 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
7342 have this prefix, so we need to skip this prefix if present. */
7343 if (function_name_len > 5 /* "_ada_" */
7344 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
7345 {
7346 function_name += 5;
7347 function_name_len -= 5;
7348 }
4c4b4cd2
PH
7349
7350 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
7351 strncpy (rename, function_name, function_name_len);
7352 xsnprintf (rename + function_name_len, rename_len - function_name_len,
7353 "__%s___XR", name);
4c4b4cd2
PH
7354 }
7355 else
7356 {
7357 const int rename_len = strlen (name) + 6;
5b4ee69b 7358
4c4b4cd2 7359 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 7360 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
7361 }
7362
852dff6c 7363 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
7364}
7365
14f9c5c9 7366/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 7367 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 7368 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
7369 otherwise return 0. */
7370
14f9c5c9 7371int
d2e4a39e 7372ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
7373{
7374 if (type1 == NULL)
7375 return 1;
7376 else if (type0 == NULL)
7377 return 0;
7378 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7379 return 1;
7380 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7381 return 0;
4c4b4cd2
PH
7382 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7383 return 1;
ad82864c 7384 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 7385 return 1;
4c4b4cd2
PH
7386 else if (ada_is_array_descriptor_type (type0)
7387 && !ada_is_array_descriptor_type (type1))
14f9c5c9 7388 return 1;
aeb5907d
JB
7389 else
7390 {
7391 const char *type0_name = type_name_no_tag (type0);
7392 const char *type1_name = type_name_no_tag (type1);
7393
7394 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7395 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7396 return 1;
7397 }
14f9c5c9
AS
7398 return 0;
7399}
7400
7401/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
7402 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7403
0d5cff50 7404const char *
d2e4a39e 7405ada_type_name (struct type *type)
14f9c5c9 7406{
d2e4a39e 7407 if (type == NULL)
14f9c5c9
AS
7408 return NULL;
7409 else if (TYPE_NAME (type) != NULL)
7410 return TYPE_NAME (type);
7411 else
7412 return TYPE_TAG_NAME (type);
7413}
7414
b4ba55a1
JB
7415/* Search the list of "descriptive" types associated to TYPE for a type
7416 whose name is NAME. */
7417
7418static struct type *
7419find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7420{
7421 struct type *result;
7422
7423 /* If there no descriptive-type info, then there is no parallel type
7424 to be found. */
7425 if (!HAVE_GNAT_AUX_INFO (type))
7426 return NULL;
7427
7428 result = TYPE_DESCRIPTIVE_TYPE (type);
7429 while (result != NULL)
7430 {
0d5cff50 7431 const char *result_name = ada_type_name (result);
b4ba55a1
JB
7432
7433 if (result_name == NULL)
7434 {
7435 warning (_("unexpected null name on descriptive type"));
7436 return NULL;
7437 }
7438
7439 /* If the names match, stop. */
7440 if (strcmp (result_name, name) == 0)
7441 break;
7442
7443 /* Otherwise, look at the next item on the list, if any. */
7444 if (HAVE_GNAT_AUX_INFO (result))
7445 result = TYPE_DESCRIPTIVE_TYPE (result);
7446 else
7447 result = NULL;
7448 }
7449
7450 /* If we didn't find a match, see whether this is a packed array. With
7451 older compilers, the descriptive type information is either absent or
7452 irrelevant when it comes to packed arrays so the above lookup fails.
7453 Fall back to using a parallel lookup by name in this case. */
12ab9e09 7454 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
7455 return ada_find_any_type (name);
7456
7457 return result;
7458}
7459
7460/* Find a parallel type to TYPE with the specified NAME, using the
7461 descriptive type taken from the debugging information, if available,
7462 and otherwise using the (slower) name-based method. */
7463
7464static struct type *
7465ada_find_parallel_type_with_name (struct type *type, const char *name)
7466{
7467 struct type *result = NULL;
7468
7469 if (HAVE_GNAT_AUX_INFO (type))
7470 result = find_parallel_type_by_descriptive_type (type, name);
7471 else
7472 result = ada_find_any_type (name);
7473
7474 return result;
7475}
7476
7477/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 7478 SUFFIX to the name of TYPE. */
14f9c5c9 7479
d2e4a39e 7480struct type *
ebf56fd3 7481ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 7482{
0d5cff50
DE
7483 char *name;
7484 const char *typename = ada_type_name (type);
14f9c5c9 7485 int len;
d2e4a39e 7486
14f9c5c9
AS
7487 if (typename == NULL)
7488 return NULL;
7489
7490 len = strlen (typename);
7491
b4ba55a1 7492 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9
AS
7493
7494 strcpy (name, typename);
7495 strcpy (name + len, suffix);
7496
b4ba55a1 7497 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
7498}
7499
14f9c5c9 7500/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 7501 type describing its fields. Otherwise, return NULL. */
14f9c5c9 7502
d2e4a39e
AS
7503static struct type *
7504dynamic_template_type (struct type *type)
14f9c5c9 7505{
61ee279c 7506 type = ada_check_typedef (type);
14f9c5c9
AS
7507
7508 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 7509 || ada_type_name (type) == NULL)
14f9c5c9 7510 return NULL;
d2e4a39e 7511 else
14f9c5c9
AS
7512 {
7513 int len = strlen (ada_type_name (type));
5b4ee69b 7514
4c4b4cd2
PH
7515 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7516 return type;
14f9c5c9 7517 else
4c4b4cd2 7518 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
7519 }
7520}
7521
7522/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 7523 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 7524
d2e4a39e
AS
7525static int
7526is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
7527{
7528 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 7529
d2e4a39e 7530 return name != NULL
14f9c5c9
AS
7531 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
7532 && strstr (name, "___XVL") != NULL;
7533}
7534
4c4b4cd2
PH
7535/* The index of the variant field of TYPE, or -1 if TYPE does not
7536 represent a variant record type. */
14f9c5c9 7537
d2e4a39e 7538static int
4c4b4cd2 7539variant_field_index (struct type *type)
14f9c5c9
AS
7540{
7541 int f;
7542
4c4b4cd2
PH
7543 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
7544 return -1;
7545
7546 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
7547 {
7548 if (ada_is_variant_part (type, f))
7549 return f;
7550 }
7551 return -1;
14f9c5c9
AS
7552}
7553
4c4b4cd2
PH
7554/* A record type with no fields. */
7555
d2e4a39e 7556static struct type *
e9bb382b 7557empty_record (struct type *template)
14f9c5c9 7558{
e9bb382b 7559 struct type *type = alloc_type_copy (template);
5b4ee69b 7560
14f9c5c9
AS
7561 TYPE_CODE (type) = TYPE_CODE_STRUCT;
7562 TYPE_NFIELDS (type) = 0;
7563 TYPE_FIELDS (type) = NULL;
b1f33ddd 7564 INIT_CPLUS_SPECIFIC (type);
14f9c5c9
AS
7565 TYPE_NAME (type) = "<empty>";
7566 TYPE_TAG_NAME (type) = NULL;
14f9c5c9
AS
7567 TYPE_LENGTH (type) = 0;
7568 return type;
7569}
7570
7571/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
7572 the value of type TYPE at VALADDR or ADDRESS (see comments at
7573 the beginning of this section) VAL according to GNAT conventions.
7574 DVAL0 should describe the (portion of a) record that contains any
df407dfe 7575 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
7576 an outer-level type (i.e., as opposed to a branch of a variant.) A
7577 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 7578 of the variant.
14f9c5c9 7579
4c4b4cd2
PH
7580 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7581 length are not statically known are discarded. As a consequence,
7582 VALADDR, ADDRESS and DVAL0 are ignored.
7583
7584 NOTE: Limitations: For now, we assume that dynamic fields and
7585 variants occupy whole numbers of bytes. However, they need not be
7586 byte-aligned. */
7587
7588struct type *
10a2c479 7589ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 7590 const gdb_byte *valaddr,
4c4b4cd2
PH
7591 CORE_ADDR address, struct value *dval0,
7592 int keep_dynamic_fields)
14f9c5c9 7593{
d2e4a39e
AS
7594 struct value *mark = value_mark ();
7595 struct value *dval;
7596 struct type *rtype;
14f9c5c9 7597 int nfields, bit_len;
4c4b4cd2 7598 int variant_field;
14f9c5c9 7599 long off;
d94e4f4f 7600 int fld_bit_len;
14f9c5c9
AS
7601 int f;
7602
4c4b4cd2
PH
7603 /* Compute the number of fields in this record type that are going
7604 to be processed: unless keep_dynamic_fields, this includes only
7605 fields whose position and length are static will be processed. */
7606 if (keep_dynamic_fields)
7607 nfields = TYPE_NFIELDS (type);
7608 else
7609 {
7610 nfields = 0;
76a01679 7611 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
7612 && !ada_is_variant_part (type, nfields)
7613 && !is_dynamic_field (type, nfields))
7614 nfields++;
7615 }
7616
e9bb382b 7617 rtype = alloc_type_copy (type);
14f9c5c9
AS
7618 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7619 INIT_CPLUS_SPECIFIC (rtype);
7620 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 7621 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
7622 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7623 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
7624 TYPE_NAME (rtype) = ada_type_name (type);
7625 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7626 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 7627
d2e4a39e
AS
7628 off = 0;
7629 bit_len = 0;
4c4b4cd2
PH
7630 variant_field = -1;
7631
14f9c5c9
AS
7632 for (f = 0; f < nfields; f += 1)
7633 {
6c038f32
PH
7634 off = align_value (off, field_alignment (type, f))
7635 + TYPE_FIELD_BITPOS (type, f);
945b3a32 7636 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 7637 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 7638
d2e4a39e 7639 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
7640 {
7641 variant_field = f;
d94e4f4f 7642 fld_bit_len = 0;
4c4b4cd2 7643 }
14f9c5c9 7644 else if (is_dynamic_field (type, f))
4c4b4cd2 7645 {
284614f0
JB
7646 const gdb_byte *field_valaddr = valaddr;
7647 CORE_ADDR field_address = address;
7648 struct type *field_type =
7649 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
7650
4c4b4cd2 7651 if (dval0 == NULL)
b5304971
JG
7652 {
7653 /* rtype's length is computed based on the run-time
7654 value of discriminants. If the discriminants are not
7655 initialized, the type size may be completely bogus and
0963b4bd 7656 GDB may fail to allocate a value for it. So check the
b5304971
JG
7657 size first before creating the value. */
7658 check_size (rtype);
7659 dval = value_from_contents_and_address (rtype, valaddr, address);
7660 }
4c4b4cd2
PH
7661 else
7662 dval = dval0;
7663
284614f0
JB
7664 /* If the type referenced by this field is an aligner type, we need
7665 to unwrap that aligner type, because its size might not be set.
7666 Keeping the aligner type would cause us to compute the wrong
7667 size for this field, impacting the offset of the all the fields
7668 that follow this one. */
7669 if (ada_is_aligner_type (field_type))
7670 {
7671 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
7672
7673 field_valaddr = cond_offset_host (field_valaddr, field_offset);
7674 field_address = cond_offset_target (field_address, field_offset);
7675 field_type = ada_aligned_type (field_type);
7676 }
7677
7678 field_valaddr = cond_offset_host (field_valaddr,
7679 off / TARGET_CHAR_BIT);
7680 field_address = cond_offset_target (field_address,
7681 off / TARGET_CHAR_BIT);
7682
7683 /* Get the fixed type of the field. Note that, in this case,
7684 we do not want to get the real type out of the tag: if
7685 the current field is the parent part of a tagged record,
7686 we will get the tag of the object. Clearly wrong: the real
7687 type of the parent is not the real type of the child. We
7688 would end up in an infinite loop. */
7689 field_type = ada_get_base_type (field_type);
7690 field_type = ada_to_fixed_type (field_type, field_valaddr,
7691 field_address, dval, 0);
27f2a97b
JB
7692 /* If the field size is already larger than the maximum
7693 object size, then the record itself will necessarily
7694 be larger than the maximum object size. We need to make
7695 this check now, because the size might be so ridiculously
7696 large (due to an uninitialized variable in the inferior)
7697 that it would cause an overflow when adding it to the
7698 record size. */
7699 check_size (field_type);
284614f0
JB
7700
7701 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 7702 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
7703 /* The multiplication can potentially overflow. But because
7704 the field length has been size-checked just above, and
7705 assuming that the maximum size is a reasonable value,
7706 an overflow should not happen in practice. So rather than
7707 adding overflow recovery code to this already complex code,
7708 we just assume that it's not going to happen. */
d94e4f4f 7709 fld_bit_len =
4c4b4cd2
PH
7710 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
7711 }
14f9c5c9 7712 else
4c4b4cd2 7713 {
5ded5331
JB
7714 /* Note: If this field's type is a typedef, it is important
7715 to preserve the typedef layer.
7716
7717 Otherwise, we might be transforming a typedef to a fat
7718 pointer (encoding a pointer to an unconstrained array),
7719 into a basic fat pointer (encoding an unconstrained
7720 array). As both types are implemented using the same
7721 structure, the typedef is the only clue which allows us
7722 to distinguish between the two options. Stripping it
7723 would prevent us from printing this field appropriately. */
7724 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
7725 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7726 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 7727 fld_bit_len =
4c4b4cd2
PH
7728 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7729 else
5ded5331
JB
7730 {
7731 struct type *field_type = TYPE_FIELD_TYPE (type, f);
7732
7733 /* We need to be careful of typedefs when computing
7734 the length of our field. If this is a typedef,
7735 get the length of the target type, not the length
7736 of the typedef. */
7737 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
7738 field_type = ada_typedef_target_type (field_type);
7739
7740 fld_bit_len =
7741 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7742 }
4c4b4cd2 7743 }
14f9c5c9 7744 if (off + fld_bit_len > bit_len)
4c4b4cd2 7745 bit_len = off + fld_bit_len;
d94e4f4f 7746 off += fld_bit_len;
4c4b4cd2
PH
7747 TYPE_LENGTH (rtype) =
7748 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 7749 }
4c4b4cd2
PH
7750
7751 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 7752 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
7753 the record. This can happen in the presence of representation
7754 clauses. */
7755 if (variant_field >= 0)
7756 {
7757 struct type *branch_type;
7758
7759 off = TYPE_FIELD_BITPOS (rtype, variant_field);
7760
7761 if (dval0 == NULL)
7762 dval = value_from_contents_and_address (rtype, valaddr, address);
7763 else
7764 dval = dval0;
7765
7766 branch_type =
7767 to_fixed_variant_branch_type
7768 (TYPE_FIELD_TYPE (type, variant_field),
7769 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7770 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7771 if (branch_type == NULL)
7772 {
7773 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
7774 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7775 TYPE_NFIELDS (rtype) -= 1;
7776 }
7777 else
7778 {
7779 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7780 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7781 fld_bit_len =
7782 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
7783 TARGET_CHAR_BIT;
7784 if (off + fld_bit_len > bit_len)
7785 bit_len = off + fld_bit_len;
7786 TYPE_LENGTH (rtype) =
7787 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7788 }
7789 }
7790
714e53ab
PH
7791 /* According to exp_dbug.ads, the size of TYPE for variable-size records
7792 should contain the alignment of that record, which should be a strictly
7793 positive value. If null or negative, then something is wrong, most
7794 probably in the debug info. In that case, we don't round up the size
0963b4bd 7795 of the resulting type. If this record is not part of another structure,
714e53ab
PH
7796 the current RTYPE length might be good enough for our purposes. */
7797 if (TYPE_LENGTH (type) <= 0)
7798 {
323e0a4a
AC
7799 if (TYPE_NAME (rtype))
7800 warning (_("Invalid type size for `%s' detected: %d."),
7801 TYPE_NAME (rtype), TYPE_LENGTH (type));
7802 else
7803 warning (_("Invalid type size for <unnamed> detected: %d."),
7804 TYPE_LENGTH (type));
714e53ab
PH
7805 }
7806 else
7807 {
7808 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
7809 TYPE_LENGTH (type));
7810 }
14f9c5c9
AS
7811
7812 value_free_to_mark (mark);
d2e4a39e 7813 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 7814 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
7815 return rtype;
7816}
7817
4c4b4cd2
PH
7818/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7819 of 1. */
14f9c5c9 7820
d2e4a39e 7821static struct type *
fc1a4b47 7822template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
7823 CORE_ADDR address, struct value *dval0)
7824{
7825 return ada_template_to_fixed_record_type_1 (type, valaddr,
7826 address, dval0, 1);
7827}
7828
7829/* An ordinary record type in which ___XVL-convention fields and
7830 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7831 static approximations, containing all possible fields. Uses
7832 no runtime values. Useless for use in values, but that's OK,
7833 since the results are used only for type determinations. Works on both
7834 structs and unions. Representation note: to save space, we memorize
7835 the result of this function in the TYPE_TARGET_TYPE of the
7836 template type. */
7837
7838static struct type *
7839template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
7840{
7841 struct type *type;
7842 int nfields;
7843 int f;
7844
4c4b4cd2
PH
7845 if (TYPE_TARGET_TYPE (type0) != NULL)
7846 return TYPE_TARGET_TYPE (type0);
7847
7848 nfields = TYPE_NFIELDS (type0);
7849 type = type0;
14f9c5c9
AS
7850
7851 for (f = 0; f < nfields; f += 1)
7852 {
61ee279c 7853 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
4c4b4cd2 7854 struct type *new_type;
14f9c5c9 7855
4c4b4cd2
PH
7856 if (is_dynamic_field (type0, f))
7857 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
14f9c5c9 7858 else
f192137b 7859 new_type = static_unwrap_type (field_type);
4c4b4cd2
PH
7860 if (type == type0 && new_type != field_type)
7861 {
e9bb382b 7862 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
4c4b4cd2
PH
7863 TYPE_CODE (type) = TYPE_CODE (type0);
7864 INIT_CPLUS_SPECIFIC (type);
7865 TYPE_NFIELDS (type) = nfields;
7866 TYPE_FIELDS (type) = (struct field *)
7867 TYPE_ALLOC (type, nfields * sizeof (struct field));
7868 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
7869 sizeof (struct field) * nfields);
7870 TYPE_NAME (type) = ada_type_name (type0);
7871 TYPE_TAG_NAME (type) = NULL;
876cecd0 7872 TYPE_FIXED_INSTANCE (type) = 1;
4c4b4cd2
PH
7873 TYPE_LENGTH (type) = 0;
7874 }
7875 TYPE_FIELD_TYPE (type, f) = new_type;
7876 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
14f9c5c9 7877 }
14f9c5c9
AS
7878 return type;
7879}
7880
4c4b4cd2 7881/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
7882 whose address in memory is ADDRESS, returns a revision of TYPE,
7883 which should be a non-dynamic-sized record, in which the variant
7884 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
7885 for discriminant values in DVAL0, which can be NULL if the record
7886 contains the necessary discriminant values. */
7887
d2e4a39e 7888static struct type *
fc1a4b47 7889to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 7890 CORE_ADDR address, struct value *dval0)
14f9c5c9 7891{
d2e4a39e 7892 struct value *mark = value_mark ();
4c4b4cd2 7893 struct value *dval;
d2e4a39e 7894 struct type *rtype;
14f9c5c9
AS
7895 struct type *branch_type;
7896 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 7897 int variant_field = variant_field_index (type);
14f9c5c9 7898
4c4b4cd2 7899 if (variant_field == -1)
14f9c5c9
AS
7900 return type;
7901
4c4b4cd2
PH
7902 if (dval0 == NULL)
7903 dval = value_from_contents_and_address (type, valaddr, address);
7904 else
7905 dval = dval0;
7906
e9bb382b 7907 rtype = alloc_type_copy (type);
14f9c5c9 7908 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
7909 INIT_CPLUS_SPECIFIC (rtype);
7910 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
7911 TYPE_FIELDS (rtype) =
7912 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7913 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 7914 sizeof (struct field) * nfields);
14f9c5c9
AS
7915 TYPE_NAME (rtype) = ada_type_name (type);
7916 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7917 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
7918 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7919
4c4b4cd2
PH
7920 branch_type = to_fixed_variant_branch_type
7921 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 7922 cond_offset_host (valaddr,
4c4b4cd2
PH
7923 TYPE_FIELD_BITPOS (type, variant_field)
7924 / TARGET_CHAR_BIT),
d2e4a39e 7925 cond_offset_target (address,
4c4b4cd2
PH
7926 TYPE_FIELD_BITPOS (type, variant_field)
7927 / TARGET_CHAR_BIT), dval);
d2e4a39e 7928 if (branch_type == NULL)
14f9c5c9 7929 {
4c4b4cd2 7930 int f;
5b4ee69b 7931
4c4b4cd2
PH
7932 for (f = variant_field + 1; f < nfields; f += 1)
7933 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 7934 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
7935 }
7936 else
7937 {
4c4b4cd2
PH
7938 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7939 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7940 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 7941 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 7942 }
4c4b4cd2 7943 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 7944
4c4b4cd2 7945 value_free_to_mark (mark);
14f9c5c9
AS
7946 return rtype;
7947}
7948
7949/* An ordinary record type (with fixed-length fields) that describes
7950 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7951 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
7952 should be in DVAL, a record value; it may be NULL if the object
7953 at ADDR itself contains any necessary discriminant values.
7954 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7955 values from the record are needed. Except in the case that DVAL,
7956 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7957 unchecked) is replaced by a particular branch of the variant.
7958
7959 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7960 is questionable and may be removed. It can arise during the
7961 processing of an unconstrained-array-of-record type where all the
7962 variant branches have exactly the same size. This is because in
7963 such cases, the compiler does not bother to use the XVS convention
7964 when encoding the record. I am currently dubious of this
7965 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 7966
d2e4a39e 7967static struct type *
fc1a4b47 7968to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 7969 CORE_ADDR address, struct value *dval)
14f9c5c9 7970{
d2e4a39e 7971 struct type *templ_type;
14f9c5c9 7972
876cecd0 7973 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
7974 return type0;
7975
d2e4a39e 7976 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
7977
7978 if (templ_type != NULL)
7979 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
7980 else if (variant_field_index (type0) >= 0)
7981 {
7982 if (dval == NULL && valaddr == NULL && address == 0)
7983 return type0;
7984 return to_record_with_fixed_variant_part (type0, valaddr, address,
7985 dval);
7986 }
14f9c5c9
AS
7987 else
7988 {
876cecd0 7989 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
7990 return type0;
7991 }
7992
7993}
7994
7995/* An ordinary record type (with fixed-length fields) that describes
7996 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7997 union type. Any necessary discriminants' values should be in DVAL,
7998 a record value. That is, this routine selects the appropriate
7999 branch of the union at ADDR according to the discriminant value
b1f33ddd 8000 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8001 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8002
d2e4a39e 8003static struct type *
fc1a4b47 8004to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8005 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8006{
8007 int which;
d2e4a39e
AS
8008 struct type *templ_type;
8009 struct type *var_type;
14f9c5c9
AS
8010
8011 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8012 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8013 else
14f9c5c9
AS
8014 var_type = var_type0;
8015
8016 templ_type = ada_find_parallel_type (var_type, "___XVU");
8017
8018 if (templ_type != NULL)
8019 var_type = templ_type;
8020
b1f33ddd
JB
8021 if (is_unchecked_variant (var_type, value_type (dval)))
8022 return var_type0;
d2e4a39e
AS
8023 which =
8024 ada_which_variant_applies (var_type,
0fd88904 8025 value_type (dval), value_contents (dval));
14f9c5c9
AS
8026
8027 if (which < 0)
e9bb382b 8028 return empty_record (var_type);
14f9c5c9 8029 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8030 return to_fixed_record_type
d2e4a39e
AS
8031 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8032 valaddr, address, dval);
4c4b4cd2 8033 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8034 return
8035 to_fixed_record_type
8036 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8037 else
8038 return TYPE_FIELD_TYPE (var_type, which);
8039}
8040
8041/* Assuming that TYPE0 is an array type describing the type of a value
8042 at ADDR, and that DVAL describes a record containing any
8043 discriminants used in TYPE0, returns a type for the value that
8044 contains no dynamic components (that is, no components whose sizes
8045 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8046 true, gives an error message if the resulting type's size is over
4c4b4cd2 8047 varsize_limit. */
14f9c5c9 8048
d2e4a39e
AS
8049static struct type *
8050to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8051 int ignore_too_big)
14f9c5c9 8052{
d2e4a39e
AS
8053 struct type *index_type_desc;
8054 struct type *result;
ad82864c 8055 int constrained_packed_array_p;
14f9c5c9 8056
b0dd7688 8057 type0 = ada_check_typedef (type0);
284614f0 8058 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8059 return type0;
14f9c5c9 8060
ad82864c
JB
8061 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8062 if (constrained_packed_array_p)
8063 type0 = decode_constrained_packed_array_type (type0);
284614f0 8064
14f9c5c9 8065 index_type_desc = ada_find_parallel_type (type0, "___XA");
28c85d6c 8066 ada_fixup_array_indexes_type (index_type_desc);
14f9c5c9
AS
8067 if (index_type_desc == NULL)
8068 {
61ee279c 8069 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8070
14f9c5c9 8071 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8072 depend on the contents of the array in properly constructed
8073 debugging data. */
529cad9c
PH
8074 /* Create a fixed version of the array element type.
8075 We're not providing the address of an element here,
e1d5a0d2 8076 and thus the actual object value cannot be inspected to do
529cad9c
PH
8077 the conversion. This should not be a problem, since arrays of
8078 unconstrained objects are not allowed. In particular, all
8079 the elements of an array of a tagged type should all be of
8080 the same type specified in the debugging info. No need to
8081 consult the object tag. */
1ed6ede0 8082 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8083
284614f0
JB
8084 /* Make sure we always create a new array type when dealing with
8085 packed array types, since we're going to fix-up the array
8086 type length and element bitsize a little further down. */
ad82864c 8087 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8088 result = type0;
14f9c5c9 8089 else
e9bb382b 8090 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8091 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8092 }
8093 else
8094 {
8095 int i;
8096 struct type *elt_type0;
8097
8098 elt_type0 = type0;
8099 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8100 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8101
8102 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8103 depend on the contents of the array in properly constructed
8104 debugging data. */
529cad9c
PH
8105 /* Create a fixed version of the array element type.
8106 We're not providing the address of an element here,
e1d5a0d2 8107 and thus the actual object value cannot be inspected to do
529cad9c
PH
8108 the conversion. This should not be a problem, since arrays of
8109 unconstrained objects are not allowed. In particular, all
8110 the elements of an array of a tagged type should all be of
8111 the same type specified in the debugging info. No need to
8112 consult the object tag. */
1ed6ede0
JB
8113 result =
8114 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8115
8116 elt_type0 = type0;
14f9c5c9 8117 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8118 {
8119 struct type *range_type =
28c85d6c 8120 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8121
e9bb382b 8122 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8123 result, range_type);
1ce677a4 8124 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8125 }
d2e4a39e 8126 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8127 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8128 }
8129
2e6fda7d
JB
8130 /* We want to preserve the type name. This can be useful when
8131 trying to get the type name of a value that has already been
8132 printed (for instance, if the user did "print VAR; whatis $". */
8133 TYPE_NAME (result) = TYPE_NAME (type0);
8134
ad82864c 8135 if (constrained_packed_array_p)
284614f0
JB
8136 {
8137 /* So far, the resulting type has been created as if the original
8138 type was a regular (non-packed) array type. As a result, the
8139 bitsize of the array elements needs to be set again, and the array
8140 length needs to be recomputed based on that bitsize. */
8141 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8142 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8143
8144 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8145 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8146 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8147 TYPE_LENGTH (result)++;
8148 }
8149
876cecd0 8150 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8151 return result;
d2e4a39e 8152}
14f9c5c9
AS
8153
8154
8155/* A standard type (containing no dynamically sized components)
8156 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8157 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8158 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8159 ADDRESS or in VALADDR contains these discriminants.
8160
1ed6ede0
JB
8161 If CHECK_TAG is not null, in the case of tagged types, this function
8162 attempts to locate the object's tag and use it to compute the actual
8163 type. However, when ADDRESS is null, we cannot use it to determine the
8164 location of the tag, and therefore compute the tagged type's actual type.
8165 So we return the tagged type without consulting the tag. */
529cad9c 8166
f192137b
JB
8167static struct type *
8168ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 8169 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 8170{
61ee279c 8171 type = ada_check_typedef (type);
d2e4a39e
AS
8172 switch (TYPE_CODE (type))
8173 {
8174 default:
14f9c5c9 8175 return type;
d2e4a39e 8176 case TYPE_CODE_STRUCT:
4c4b4cd2 8177 {
76a01679 8178 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
8179 struct type *fixed_record_type =
8180 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 8181
529cad9c
PH
8182 /* If STATIC_TYPE is a tagged type and we know the object's address,
8183 then we can determine its tag, and compute the object's actual
0963b4bd 8184 type from there. Note that we have to use the fixed record
1ed6ede0
JB
8185 type (the parent part of the record may have dynamic fields
8186 and the way the location of _tag is expressed may depend on
8187 them). */
529cad9c 8188
1ed6ede0 8189 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 8190 {
b50d69b5
JG
8191 struct value *tag =
8192 value_tag_from_contents_and_address
8193 (fixed_record_type,
8194 valaddr,
8195 address);
8196 struct type *real_type = type_from_tag (tag);
8197 struct value *obj =
8198 value_from_contents_and_address (fixed_record_type,
8199 valaddr,
8200 address);
76a01679 8201 if (real_type != NULL)
b50d69b5
JG
8202 return to_fixed_record_type
8203 (real_type, NULL,
8204 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 8205 }
4af88198
JB
8206
8207 /* Check to see if there is a parallel ___XVZ variable.
8208 If there is, then it provides the actual size of our type. */
8209 else if (ada_type_name (fixed_record_type) != NULL)
8210 {
0d5cff50 8211 const char *name = ada_type_name (fixed_record_type);
4af88198
JB
8212 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
8213 int xvz_found = 0;
8214 LONGEST size;
8215
88c15c34 8216 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
4af88198
JB
8217 size = get_int_var_value (xvz_name, &xvz_found);
8218 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8219 {
8220 fixed_record_type = copy_type (fixed_record_type);
8221 TYPE_LENGTH (fixed_record_type) = size;
8222
8223 /* The FIXED_RECORD_TYPE may have be a stub. We have
8224 observed this when the debugging info is STABS, and
8225 apparently it is something that is hard to fix.
8226
8227 In practice, we don't need the actual type definition
8228 at all, because the presence of the XVZ variable allows us
8229 to assume that there must be a XVS type as well, which we
8230 should be able to use later, when we need the actual type
8231 definition.
8232
8233 In the meantime, pretend that the "fixed" type we are
8234 returning is NOT a stub, because this can cause trouble
8235 when using this type to create new types targeting it.
8236 Indeed, the associated creation routines often check
8237 whether the target type is a stub and will try to replace
0963b4bd 8238 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
8239 might cause the new type to have the wrong size too.
8240 Consider the case of an array, for instance, where the size
8241 of the array is computed from the number of elements in
8242 our array multiplied by the size of its element. */
8243 TYPE_STUB (fixed_record_type) = 0;
8244 }
8245 }
1ed6ede0 8246 return fixed_record_type;
4c4b4cd2 8247 }
d2e4a39e 8248 case TYPE_CODE_ARRAY:
4c4b4cd2 8249 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
8250 case TYPE_CODE_UNION:
8251 if (dval == NULL)
4c4b4cd2 8252 return type;
d2e4a39e 8253 else
4c4b4cd2 8254 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 8255 }
14f9c5c9
AS
8256}
8257
f192137b
JB
8258/* The same as ada_to_fixed_type_1, except that it preserves the type
8259 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
8260
8261 The typedef layer needs be preserved in order to differentiate between
8262 arrays and array pointers when both types are implemented using the same
8263 fat pointer. In the array pointer case, the pointer is encoded as
8264 a typedef of the pointer type. For instance, considering:
8265
8266 type String_Access is access String;
8267 S1 : String_Access := null;
8268
8269 To the debugger, S1 is defined as a typedef of type String. But
8270 to the user, it is a pointer. So if the user tries to print S1,
8271 we should not dereference the array, but print the array address
8272 instead.
8273
8274 If we didn't preserve the typedef layer, we would lose the fact that
8275 the type is to be presented as a pointer (needs de-reference before
8276 being printed). And we would also use the source-level type name. */
f192137b
JB
8277
8278struct type *
8279ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8280 CORE_ADDR address, struct value *dval, int check_tag)
8281
8282{
8283 struct type *fixed_type =
8284 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8285
96dbd2c1
JB
8286 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8287 then preserve the typedef layer.
8288
8289 Implementation note: We can only check the main-type portion of
8290 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8291 from TYPE now returns a type that has the same instance flags
8292 as TYPE. For instance, if TYPE is a "typedef const", and its
8293 target type is a "struct", then the typedef elimination will return
8294 a "const" version of the target type. See check_typedef for more
8295 details about how the typedef layer elimination is done.
8296
8297 brobecker/2010-11-19: It seems to me that the only case where it is
8298 useful to preserve the typedef layer is when dealing with fat pointers.
8299 Perhaps, we could add a check for that and preserve the typedef layer
8300 only in that situation. But this seems unecessary so far, probably
8301 because we call check_typedef/ada_check_typedef pretty much everywhere.
8302 */
f192137b 8303 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 8304 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 8305 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
8306 return type;
8307
8308 return fixed_type;
8309}
8310
14f9c5c9 8311/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 8312 TYPE0, but based on no runtime data. */
14f9c5c9 8313
d2e4a39e
AS
8314static struct type *
8315to_static_fixed_type (struct type *type0)
14f9c5c9 8316{
d2e4a39e 8317 struct type *type;
14f9c5c9
AS
8318
8319 if (type0 == NULL)
8320 return NULL;
8321
876cecd0 8322 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8323 return type0;
8324
61ee279c 8325 type0 = ada_check_typedef (type0);
d2e4a39e 8326
14f9c5c9
AS
8327 switch (TYPE_CODE (type0))
8328 {
8329 default:
8330 return type0;
8331 case TYPE_CODE_STRUCT:
8332 type = dynamic_template_type (type0);
d2e4a39e 8333 if (type != NULL)
4c4b4cd2
PH
8334 return template_to_static_fixed_type (type);
8335 else
8336 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8337 case TYPE_CODE_UNION:
8338 type = ada_find_parallel_type (type0, "___XVU");
8339 if (type != NULL)
4c4b4cd2
PH
8340 return template_to_static_fixed_type (type);
8341 else
8342 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8343 }
8344}
8345
4c4b4cd2
PH
8346/* A static approximation of TYPE with all type wrappers removed. */
8347
d2e4a39e
AS
8348static struct type *
8349static_unwrap_type (struct type *type)
14f9c5c9
AS
8350{
8351 if (ada_is_aligner_type (type))
8352 {
61ee279c 8353 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 8354 if (ada_type_name (type1) == NULL)
4c4b4cd2 8355 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
8356
8357 return static_unwrap_type (type1);
8358 }
d2e4a39e 8359 else
14f9c5c9 8360 {
d2e4a39e 8361 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 8362
d2e4a39e 8363 if (raw_real_type == type)
4c4b4cd2 8364 return type;
14f9c5c9 8365 else
4c4b4cd2 8366 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
8367 }
8368}
8369
8370/* In some cases, incomplete and private types require
4c4b4cd2 8371 cross-references that are not resolved as records (for example,
14f9c5c9
AS
8372 type Foo;
8373 type FooP is access Foo;
8374 V: FooP;
8375 type Foo is array ...;
4c4b4cd2 8376 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
8377 cross-references to such types, we instead substitute for FooP a
8378 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 8379 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
8380
8381/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
8382 exists, otherwise TYPE. */
8383
d2e4a39e 8384struct type *
61ee279c 8385ada_check_typedef (struct type *type)
14f9c5c9 8386{
727e3d2e
JB
8387 if (type == NULL)
8388 return NULL;
8389
720d1a40
JB
8390 /* If our type is a typedef type of a fat pointer, then we're done.
8391 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8392 what allows us to distinguish between fat pointers that represent
8393 array types, and fat pointers that represent array access types
8394 (in both cases, the compiler implements them as fat pointers). */
8395 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8396 && is_thick_pntr (ada_typedef_target_type (type)))
8397 return type;
8398
14f9c5c9
AS
8399 CHECK_TYPEDEF (type);
8400 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 8401 || !TYPE_STUB (type)
14f9c5c9
AS
8402 || TYPE_TAG_NAME (type) == NULL)
8403 return type;
d2e4a39e 8404 else
14f9c5c9 8405 {
0d5cff50 8406 const char *name = TYPE_TAG_NAME (type);
d2e4a39e 8407 struct type *type1 = ada_find_any_type (name);
5b4ee69b 8408
05e522ef
JB
8409 if (type1 == NULL)
8410 return type;
8411
8412 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8413 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
8414 types, only for the typedef-to-array types). If that's the case,
8415 strip the typedef layer. */
8416 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
8417 type1 = ada_check_typedef (type1);
8418
8419 return type1;
14f9c5c9
AS
8420 }
8421}
8422
8423/* A value representing the data at VALADDR/ADDRESS as described by
8424 type TYPE0, but with a standard (static-sized) type that correctly
8425 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8426 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 8427 creation of struct values]. */
14f9c5c9 8428
4c4b4cd2
PH
8429static struct value *
8430ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8431 struct value *val0)
14f9c5c9 8432{
1ed6ede0 8433 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 8434
14f9c5c9
AS
8435 if (type == type0 && val0 != NULL)
8436 return val0;
d2e4a39e 8437 else
4c4b4cd2
PH
8438 return value_from_contents_and_address (type, 0, address);
8439}
8440
8441/* A value representing VAL, but with a standard (static-sized) type
8442 that correctly describes it. Does not necessarily create a new
8443 value. */
8444
0c3acc09 8445struct value *
4c4b4cd2
PH
8446ada_to_fixed_value (struct value *val)
8447{
c48db5ca
JB
8448 val = unwrap_value (val);
8449 val = ada_to_fixed_value_create (value_type (val),
8450 value_address (val),
8451 val);
8452 return val;
14f9c5c9 8453}
d2e4a39e 8454\f
14f9c5c9 8455
14f9c5c9
AS
8456/* Attributes */
8457
4c4b4cd2
PH
8458/* Table mapping attribute numbers to names.
8459 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 8460
d2e4a39e 8461static const char *attribute_names[] = {
14f9c5c9
AS
8462 "<?>",
8463
d2e4a39e 8464 "first",
14f9c5c9
AS
8465 "last",
8466 "length",
8467 "image",
14f9c5c9
AS
8468 "max",
8469 "min",
4c4b4cd2
PH
8470 "modulus",
8471 "pos",
8472 "size",
8473 "tag",
14f9c5c9 8474 "val",
14f9c5c9
AS
8475 0
8476};
8477
d2e4a39e 8478const char *
4c4b4cd2 8479ada_attribute_name (enum exp_opcode n)
14f9c5c9 8480{
4c4b4cd2
PH
8481 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8482 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
8483 else
8484 return attribute_names[0];
8485}
8486
4c4b4cd2 8487/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 8488
4c4b4cd2
PH
8489static LONGEST
8490pos_atr (struct value *arg)
14f9c5c9 8491{
24209737
PH
8492 struct value *val = coerce_ref (arg);
8493 struct type *type = value_type (val);
14f9c5c9 8494
d2e4a39e 8495 if (!discrete_type_p (type))
323e0a4a 8496 error (_("'POS only defined on discrete types"));
14f9c5c9
AS
8497
8498 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8499 {
8500 int i;
24209737 8501 LONGEST v = value_as_long (val);
14f9c5c9 8502
d2e4a39e 8503 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2 8504 {
14e75d8e 8505 if (v == TYPE_FIELD_ENUMVAL (type, i))
4c4b4cd2
PH
8506 return i;
8507 }
323e0a4a 8508 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9
AS
8509 }
8510 else
24209737 8511 return value_as_long (val);
4c4b4cd2
PH
8512}
8513
8514static struct value *
3cb382c9 8515value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 8516{
3cb382c9 8517 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
8518}
8519
4c4b4cd2 8520/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 8521
d2e4a39e
AS
8522static struct value *
8523value_val_atr (struct type *type, struct value *arg)
14f9c5c9 8524{
d2e4a39e 8525 if (!discrete_type_p (type))
323e0a4a 8526 error (_("'VAL only defined on discrete types"));
df407dfe 8527 if (!integer_type_p (value_type (arg)))
323e0a4a 8528 error (_("'VAL requires integral argument"));
14f9c5c9
AS
8529
8530 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8531 {
8532 long pos = value_as_long (arg);
5b4ee69b 8533
14f9c5c9 8534 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 8535 error (_("argument to 'VAL out of range"));
14e75d8e 8536 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
8537 }
8538 else
8539 return value_from_longest (type, value_as_long (arg));
8540}
14f9c5c9 8541\f
d2e4a39e 8542
4c4b4cd2 8543 /* Evaluation */
14f9c5c9 8544
4c4b4cd2
PH
8545/* True if TYPE appears to be an Ada character type.
8546 [At the moment, this is true only for Character and Wide_Character;
8547 It is a heuristic test that could stand improvement]. */
14f9c5c9 8548
d2e4a39e
AS
8549int
8550ada_is_character_type (struct type *type)
14f9c5c9 8551{
7b9f71f2
JB
8552 const char *name;
8553
8554 /* If the type code says it's a character, then assume it really is,
8555 and don't check any further. */
8556 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
8557 return 1;
8558
8559 /* Otherwise, assume it's a character type iff it is a discrete type
8560 with a known character type name. */
8561 name = ada_type_name (type);
8562 return (name != NULL
8563 && (TYPE_CODE (type) == TYPE_CODE_INT
8564 || TYPE_CODE (type) == TYPE_CODE_RANGE)
8565 && (strcmp (name, "character") == 0
8566 || strcmp (name, "wide_character") == 0
5a517ebd 8567 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 8568 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
8569}
8570
4c4b4cd2 8571/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
8572
8573int
ebf56fd3 8574ada_is_string_type (struct type *type)
14f9c5c9 8575{
61ee279c 8576 type = ada_check_typedef (type);
d2e4a39e 8577 if (type != NULL
14f9c5c9 8578 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
8579 && (ada_is_simple_array_type (type)
8580 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
8581 && ada_array_arity (type) == 1)
8582 {
8583 struct type *elttype = ada_array_element_type (type, 1);
8584
8585 return ada_is_character_type (elttype);
8586 }
d2e4a39e 8587 else
14f9c5c9
AS
8588 return 0;
8589}
8590
5bf03f13
JB
8591/* The compiler sometimes provides a parallel XVS type for a given
8592 PAD type. Normally, it is safe to follow the PAD type directly,
8593 but older versions of the compiler have a bug that causes the offset
8594 of its "F" field to be wrong. Following that field in that case
8595 would lead to incorrect results, but this can be worked around
8596 by ignoring the PAD type and using the associated XVS type instead.
8597
8598 Set to True if the debugger should trust the contents of PAD types.
8599 Otherwise, ignore the PAD type if there is a parallel XVS type. */
8600static int trust_pad_over_xvs = 1;
14f9c5c9
AS
8601
8602/* True if TYPE is a struct type introduced by the compiler to force the
8603 alignment of a value. Such types have a single field with a
4c4b4cd2 8604 distinctive name. */
14f9c5c9
AS
8605
8606int
ebf56fd3 8607ada_is_aligner_type (struct type *type)
14f9c5c9 8608{
61ee279c 8609 type = ada_check_typedef (type);
714e53ab 8610
5bf03f13 8611 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
8612 return 0;
8613
14f9c5c9 8614 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
8615 && TYPE_NFIELDS (type) == 1
8616 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
8617}
8618
8619/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 8620 the parallel type. */
14f9c5c9 8621
d2e4a39e
AS
8622struct type *
8623ada_get_base_type (struct type *raw_type)
14f9c5c9 8624{
d2e4a39e
AS
8625 struct type *real_type_namer;
8626 struct type *raw_real_type;
14f9c5c9
AS
8627
8628 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
8629 return raw_type;
8630
284614f0
JB
8631 if (ada_is_aligner_type (raw_type))
8632 /* The encoding specifies that we should always use the aligner type.
8633 So, even if this aligner type has an associated XVS type, we should
8634 simply ignore it.
8635
8636 According to the compiler gurus, an XVS type parallel to an aligner
8637 type may exist because of a stabs limitation. In stabs, aligner
8638 types are empty because the field has a variable-sized type, and
8639 thus cannot actually be used as an aligner type. As a result,
8640 we need the associated parallel XVS type to decode the type.
8641 Since the policy in the compiler is to not change the internal
8642 representation based on the debugging info format, we sometimes
8643 end up having a redundant XVS type parallel to the aligner type. */
8644 return raw_type;
8645
14f9c5c9 8646 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 8647 if (real_type_namer == NULL
14f9c5c9
AS
8648 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
8649 || TYPE_NFIELDS (real_type_namer) != 1)
8650 return raw_type;
8651
f80d3ff2
JB
8652 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
8653 {
8654 /* This is an older encoding form where the base type needs to be
8655 looked up by name. We prefer the newer enconding because it is
8656 more efficient. */
8657 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
8658 if (raw_real_type == NULL)
8659 return raw_type;
8660 else
8661 return raw_real_type;
8662 }
8663
8664 /* The field in our XVS type is a reference to the base type. */
8665 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 8666}
14f9c5c9 8667
4c4b4cd2 8668/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 8669
d2e4a39e
AS
8670struct type *
8671ada_aligned_type (struct type *type)
14f9c5c9
AS
8672{
8673 if (ada_is_aligner_type (type))
8674 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
8675 else
8676 return ada_get_base_type (type);
8677}
8678
8679
8680/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 8681 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 8682
fc1a4b47
AC
8683const gdb_byte *
8684ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 8685{
d2e4a39e 8686 if (ada_is_aligner_type (type))
14f9c5c9 8687 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
8688 valaddr +
8689 TYPE_FIELD_BITPOS (type,
8690 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
8691 else
8692 return valaddr;
8693}
8694
4c4b4cd2
PH
8695
8696
14f9c5c9 8697/* The printed representation of an enumeration literal with encoded
4c4b4cd2 8698 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
8699const char *
8700ada_enum_name (const char *name)
14f9c5c9 8701{
4c4b4cd2
PH
8702 static char *result;
8703 static size_t result_len = 0;
d2e4a39e 8704 char *tmp;
14f9c5c9 8705
4c4b4cd2
PH
8706 /* First, unqualify the enumeration name:
8707 1. Search for the last '.' character. If we find one, then skip
177b42fe 8708 all the preceding characters, the unqualified name starts
76a01679 8709 right after that dot.
4c4b4cd2 8710 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
8711 translates dots into "__". Search forward for double underscores,
8712 but stop searching when we hit an overloading suffix, which is
8713 of the form "__" followed by digits. */
4c4b4cd2 8714
c3e5cd34
PH
8715 tmp = strrchr (name, '.');
8716 if (tmp != NULL)
4c4b4cd2
PH
8717 name = tmp + 1;
8718 else
14f9c5c9 8719 {
4c4b4cd2
PH
8720 while ((tmp = strstr (name, "__")) != NULL)
8721 {
8722 if (isdigit (tmp[2]))
8723 break;
8724 else
8725 name = tmp + 2;
8726 }
14f9c5c9
AS
8727 }
8728
8729 if (name[0] == 'Q')
8730 {
14f9c5c9 8731 int v;
5b4ee69b 8732
14f9c5c9 8733 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
8734 {
8735 if (sscanf (name + 2, "%x", &v) != 1)
8736 return name;
8737 }
14f9c5c9 8738 else
4c4b4cd2 8739 return name;
14f9c5c9 8740
4c4b4cd2 8741 GROW_VECT (result, result_len, 16);
14f9c5c9 8742 if (isascii (v) && isprint (v))
88c15c34 8743 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 8744 else if (name[1] == 'U')
88c15c34 8745 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 8746 else
88c15c34 8747 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
8748
8749 return result;
8750 }
d2e4a39e 8751 else
4c4b4cd2 8752 {
c3e5cd34
PH
8753 tmp = strstr (name, "__");
8754 if (tmp == NULL)
8755 tmp = strstr (name, "$");
8756 if (tmp != NULL)
4c4b4cd2
PH
8757 {
8758 GROW_VECT (result, result_len, tmp - name + 1);
8759 strncpy (result, name, tmp - name);
8760 result[tmp - name] = '\0';
8761 return result;
8762 }
8763
8764 return name;
8765 }
14f9c5c9
AS
8766}
8767
14f9c5c9
AS
8768/* Evaluate the subexpression of EXP starting at *POS as for
8769 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 8770 expression. */
14f9c5c9 8771
d2e4a39e
AS
8772static struct value *
8773evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 8774{
4b27a620 8775 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
8776}
8777
8778/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 8779 value it wraps. */
14f9c5c9 8780
d2e4a39e
AS
8781static struct value *
8782unwrap_value (struct value *val)
14f9c5c9 8783{
df407dfe 8784 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 8785
14f9c5c9
AS
8786 if (ada_is_aligner_type (type))
8787 {
de4d072f 8788 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 8789 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 8790
14f9c5c9 8791 if (ada_type_name (val_type) == NULL)
4c4b4cd2 8792 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
8793
8794 return unwrap_value (v);
8795 }
d2e4a39e 8796 else
14f9c5c9 8797 {
d2e4a39e 8798 struct type *raw_real_type =
61ee279c 8799 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 8800
5bf03f13
JB
8801 /* If there is no parallel XVS or XVE type, then the value is
8802 already unwrapped. Return it without further modification. */
8803 if ((type == raw_real_type)
8804 && ada_find_parallel_type (type, "___XVE") == NULL)
8805 return val;
14f9c5c9 8806
d2e4a39e 8807 return
4c4b4cd2
PH
8808 coerce_unspec_val_to_type
8809 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 8810 value_address (val),
1ed6ede0 8811 NULL, 1));
14f9c5c9
AS
8812 }
8813}
d2e4a39e
AS
8814
8815static struct value *
8816cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
8817{
8818 LONGEST val;
8819
df407dfe 8820 if (type == value_type (arg))
14f9c5c9 8821 return arg;
df407dfe 8822 else if (ada_is_fixed_point_type (value_type (arg)))
d2e4a39e 8823 val = ada_float_to_fixed (type,
df407dfe 8824 ada_fixed_to_float (value_type (arg),
4c4b4cd2 8825 value_as_long (arg)));
d2e4a39e 8826 else
14f9c5c9 8827 {
a53b7a21 8828 DOUBLEST argd = value_as_double (arg);
5b4ee69b 8829
14f9c5c9
AS
8830 val = ada_float_to_fixed (type, argd);
8831 }
8832
8833 return value_from_longest (type, val);
8834}
8835
d2e4a39e 8836static struct value *
a53b7a21 8837cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 8838{
df407dfe 8839 DOUBLEST val = ada_fixed_to_float (value_type (arg),
4c4b4cd2 8840 value_as_long (arg));
5b4ee69b 8841
a53b7a21 8842 return value_from_double (type, val);
14f9c5c9
AS
8843}
8844
d99dcf51
JB
8845/* Given two array types T1 and T2, return nonzero iff both arrays
8846 contain the same number of elements. */
8847
8848static int
8849ada_same_array_size_p (struct type *t1, struct type *t2)
8850{
8851 LONGEST lo1, hi1, lo2, hi2;
8852
8853 /* Get the array bounds in order to verify that the size of
8854 the two arrays match. */
8855 if (!get_array_bounds (t1, &lo1, &hi1)
8856 || !get_array_bounds (t2, &lo2, &hi2))
8857 error (_("unable to determine array bounds"));
8858
8859 /* To make things easier for size comparison, normalize a bit
8860 the case of empty arrays by making sure that the difference
8861 between upper bound and lower bound is always -1. */
8862 if (lo1 > hi1)
8863 hi1 = lo1 - 1;
8864 if (lo2 > hi2)
8865 hi2 = lo2 - 1;
8866
8867 return (hi1 - lo1 == hi2 - lo2);
8868}
8869
8870/* Assuming that VAL is an array of integrals, and TYPE represents
8871 an array with the same number of elements, but with wider integral
8872 elements, return an array "casted" to TYPE. In practice, this
8873 means that the returned array is built by casting each element
8874 of the original array into TYPE's (wider) element type. */
8875
8876static struct value *
8877ada_promote_array_of_integrals (struct type *type, struct value *val)
8878{
8879 struct type *elt_type = TYPE_TARGET_TYPE (type);
8880 LONGEST lo, hi;
8881 struct value *res;
8882 LONGEST i;
8883
8884 /* Verify that both val and type are arrays of scalars, and
8885 that the size of val's elements is smaller than the size
8886 of type's element. */
8887 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
8888 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
8889 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
8890 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
8891 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
8892 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
8893
8894 if (!get_array_bounds (type, &lo, &hi))
8895 error (_("unable to determine array bounds"));
8896
8897 res = allocate_value (type);
8898
8899 /* Promote each array element. */
8900 for (i = 0; i < hi - lo + 1; i++)
8901 {
8902 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
8903
8904 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
8905 value_contents_all (elt), TYPE_LENGTH (elt_type));
8906 }
8907
8908 return res;
8909}
8910
4c4b4cd2
PH
8911/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8912 return the converted value. */
8913
d2e4a39e
AS
8914static struct value *
8915coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 8916{
df407dfe 8917 struct type *type2 = value_type (val);
5b4ee69b 8918
14f9c5c9
AS
8919 if (type == type2)
8920 return val;
8921
61ee279c
PH
8922 type2 = ada_check_typedef (type2);
8923 type = ada_check_typedef (type);
14f9c5c9 8924
d2e4a39e
AS
8925 if (TYPE_CODE (type2) == TYPE_CODE_PTR
8926 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
8927 {
8928 val = ada_value_ind (val);
df407dfe 8929 type2 = value_type (val);
14f9c5c9
AS
8930 }
8931
d2e4a39e 8932 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
8933 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
8934 {
d99dcf51
JB
8935 if (!ada_same_array_size_p (type, type2))
8936 error (_("cannot assign arrays of different length"));
8937
8938 if (is_integral_type (TYPE_TARGET_TYPE (type))
8939 && is_integral_type (TYPE_TARGET_TYPE (type2))
8940 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8941 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8942 {
8943 /* Allow implicit promotion of the array elements to
8944 a wider type. */
8945 return ada_promote_array_of_integrals (type, val);
8946 }
8947
8948 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8949 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 8950 error (_("Incompatible types in assignment"));
04624583 8951 deprecated_set_value_type (val, type);
14f9c5c9 8952 }
d2e4a39e 8953 return val;
14f9c5c9
AS
8954}
8955
4c4b4cd2
PH
8956static struct value *
8957ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
8958{
8959 struct value *val;
8960 struct type *type1, *type2;
8961 LONGEST v, v1, v2;
8962
994b9211
AC
8963 arg1 = coerce_ref (arg1);
8964 arg2 = coerce_ref (arg2);
18af8284
JB
8965 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
8966 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 8967
76a01679
JB
8968 if (TYPE_CODE (type1) != TYPE_CODE_INT
8969 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
8970 return value_binop (arg1, arg2, op);
8971
76a01679 8972 switch (op)
4c4b4cd2
PH
8973 {
8974 case BINOP_MOD:
8975 case BINOP_DIV:
8976 case BINOP_REM:
8977 break;
8978 default:
8979 return value_binop (arg1, arg2, op);
8980 }
8981
8982 v2 = value_as_long (arg2);
8983 if (v2 == 0)
323e0a4a 8984 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
8985
8986 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
8987 return value_binop (arg1, arg2, op);
8988
8989 v1 = value_as_long (arg1);
8990 switch (op)
8991 {
8992 case BINOP_DIV:
8993 v = v1 / v2;
76a01679
JB
8994 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
8995 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
8996 break;
8997 case BINOP_REM:
8998 v = v1 % v2;
76a01679
JB
8999 if (v * v1 < 0)
9000 v -= v2;
4c4b4cd2
PH
9001 break;
9002 default:
9003 /* Should not reach this point. */
9004 v = 0;
9005 }
9006
9007 val = allocate_value (type1);
990a07ab 9008 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9009 TYPE_LENGTH (value_type (val)),
9010 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9011 return val;
9012}
9013
9014static int
9015ada_value_equal (struct value *arg1, struct value *arg2)
9016{
df407dfe
AC
9017 if (ada_is_direct_array_type (value_type (arg1))
9018 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9019 {
f58b38bf
JB
9020 /* Automatically dereference any array reference before
9021 we attempt to perform the comparison. */
9022 arg1 = ada_coerce_ref (arg1);
9023 arg2 = ada_coerce_ref (arg2);
9024
4c4b4cd2
PH
9025 arg1 = ada_coerce_to_simple_array (arg1);
9026 arg2 = ada_coerce_to_simple_array (arg2);
df407dfe
AC
9027 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
9028 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
323e0a4a 9029 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9030 /* FIXME: The following works only for types whose
76a01679
JB
9031 representations use all bits (no padding or undefined bits)
9032 and do not have user-defined equality. */
9033 return
df407dfe 9034 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
0fd88904 9035 && memcmp (value_contents (arg1), value_contents (arg2),
df407dfe 9036 TYPE_LENGTH (value_type (arg1))) == 0;
4c4b4cd2
PH
9037 }
9038 return value_equal (arg1, arg2);
9039}
9040
52ce6436
PH
9041/* Total number of component associations in the aggregate starting at
9042 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9043 OP_AGGREGATE. */
52ce6436
PH
9044
9045static int
9046num_component_specs (struct expression *exp, int pc)
9047{
9048 int n, m, i;
5b4ee69b 9049
52ce6436
PH
9050 m = exp->elts[pc + 1].longconst;
9051 pc += 3;
9052 n = 0;
9053 for (i = 0; i < m; i += 1)
9054 {
9055 switch (exp->elts[pc].opcode)
9056 {
9057 default:
9058 n += 1;
9059 break;
9060 case OP_CHOICES:
9061 n += exp->elts[pc + 1].longconst;
9062 break;
9063 }
9064 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9065 }
9066 return n;
9067}
9068
9069/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9070 component of LHS (a simple array or a record), updating *POS past
9071 the expression, assuming that LHS is contained in CONTAINER. Does
9072 not modify the inferior's memory, nor does it modify LHS (unless
9073 LHS == CONTAINER). */
9074
9075static void
9076assign_component (struct value *container, struct value *lhs, LONGEST index,
9077 struct expression *exp, int *pos)
9078{
9079 struct value *mark = value_mark ();
9080 struct value *elt;
5b4ee69b 9081
52ce6436
PH
9082 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
9083 {
22601c15
UW
9084 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9085 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9086
52ce6436
PH
9087 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9088 }
9089 else
9090 {
9091 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9092 elt = ada_to_fixed_value (elt);
52ce6436
PH
9093 }
9094
9095 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9096 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9097 else
9098 value_assign_to_component (container, elt,
9099 ada_evaluate_subexp (NULL, exp, pos,
9100 EVAL_NORMAL));
9101
9102 value_free_to_mark (mark);
9103}
9104
9105/* Assuming that LHS represents an lvalue having a record or array
9106 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9107 of that aggregate's value to LHS, advancing *POS past the
9108 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9109 lvalue containing LHS (possibly LHS itself). Does not modify
9110 the inferior's memory, nor does it modify the contents of
0963b4bd 9111 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9112
9113static struct value *
9114assign_aggregate (struct value *container,
9115 struct value *lhs, struct expression *exp,
9116 int *pos, enum noside noside)
9117{
9118 struct type *lhs_type;
9119 int n = exp->elts[*pos+1].longconst;
9120 LONGEST low_index, high_index;
9121 int num_specs;
9122 LONGEST *indices;
9123 int max_indices, num_indices;
52ce6436 9124 int i;
52ce6436
PH
9125
9126 *pos += 3;
9127 if (noside != EVAL_NORMAL)
9128 {
52ce6436
PH
9129 for (i = 0; i < n; i += 1)
9130 ada_evaluate_subexp (NULL, exp, pos, noside);
9131 return container;
9132 }
9133
9134 container = ada_coerce_ref (container);
9135 if (ada_is_direct_array_type (value_type (container)))
9136 container = ada_coerce_to_simple_array (container);
9137 lhs = ada_coerce_ref (lhs);
9138 if (!deprecated_value_modifiable (lhs))
9139 error (_("Left operand of assignment is not a modifiable lvalue."));
9140
9141 lhs_type = value_type (lhs);
9142 if (ada_is_direct_array_type (lhs_type))
9143 {
9144 lhs = ada_coerce_to_simple_array (lhs);
9145 lhs_type = value_type (lhs);
9146 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9147 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
9148 }
9149 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9150 {
9151 low_index = 0;
9152 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
9153 }
9154 else
9155 error (_("Left-hand side must be array or record."));
9156
9157 num_specs = num_component_specs (exp, *pos - 3);
9158 max_indices = 4 * num_specs + 4;
9159 indices = alloca (max_indices * sizeof (indices[0]));
9160 indices[0] = indices[1] = low_index - 1;
9161 indices[2] = indices[3] = high_index + 1;
9162 num_indices = 4;
9163
9164 for (i = 0; i < n; i += 1)
9165 {
9166 switch (exp->elts[*pos].opcode)
9167 {
1fbf5ada
JB
9168 case OP_CHOICES:
9169 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9170 &num_indices, max_indices,
9171 low_index, high_index);
9172 break;
9173 case OP_POSITIONAL:
9174 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
9175 &num_indices, max_indices,
9176 low_index, high_index);
1fbf5ada
JB
9177 break;
9178 case OP_OTHERS:
9179 if (i != n-1)
9180 error (_("Misplaced 'others' clause"));
9181 aggregate_assign_others (container, lhs, exp, pos, indices,
9182 num_indices, low_index, high_index);
9183 break;
9184 default:
9185 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
9186 }
9187 }
9188
9189 return container;
9190}
9191
9192/* Assign into the component of LHS indexed by the OP_POSITIONAL
9193 construct at *POS, updating *POS past the construct, given that
9194 the positions are relative to lower bound LOW, where HIGH is the
9195 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9196 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 9197 assign_aggregate. */
52ce6436
PH
9198static void
9199aggregate_assign_positional (struct value *container,
9200 struct value *lhs, struct expression *exp,
9201 int *pos, LONGEST *indices, int *num_indices,
9202 int max_indices, LONGEST low, LONGEST high)
9203{
9204 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9205
9206 if (ind - 1 == high)
e1d5a0d2 9207 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
9208 if (ind <= high)
9209 {
9210 add_component_interval (ind, ind, indices, num_indices, max_indices);
9211 *pos += 3;
9212 assign_component (container, lhs, ind, exp, pos);
9213 }
9214 else
9215 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9216}
9217
9218/* Assign into the components of LHS indexed by the OP_CHOICES
9219 construct at *POS, updating *POS past the construct, given that
9220 the allowable indices are LOW..HIGH. Record the indices assigned
9221 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 9222 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9223static void
9224aggregate_assign_from_choices (struct value *container,
9225 struct value *lhs, struct expression *exp,
9226 int *pos, LONGEST *indices, int *num_indices,
9227 int max_indices, LONGEST low, LONGEST high)
9228{
9229 int j;
9230 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9231 int choice_pos, expr_pc;
9232 int is_array = ada_is_direct_array_type (value_type (lhs));
9233
9234 choice_pos = *pos += 3;
9235
9236 for (j = 0; j < n_choices; j += 1)
9237 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9238 expr_pc = *pos;
9239 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9240
9241 for (j = 0; j < n_choices; j += 1)
9242 {
9243 LONGEST lower, upper;
9244 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 9245
52ce6436
PH
9246 if (op == OP_DISCRETE_RANGE)
9247 {
9248 choice_pos += 1;
9249 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9250 EVAL_NORMAL));
9251 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9252 EVAL_NORMAL));
9253 }
9254 else if (is_array)
9255 {
9256 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9257 EVAL_NORMAL));
9258 upper = lower;
9259 }
9260 else
9261 {
9262 int ind;
0d5cff50 9263 const char *name;
5b4ee69b 9264
52ce6436
PH
9265 switch (op)
9266 {
9267 case OP_NAME:
9268 name = &exp->elts[choice_pos + 2].string;
9269 break;
9270 case OP_VAR_VALUE:
9271 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9272 break;
9273 default:
9274 error (_("Invalid record component association."));
9275 }
9276 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9277 ind = 0;
9278 if (! find_struct_field (name, value_type (lhs), 0,
9279 NULL, NULL, NULL, NULL, &ind))
9280 error (_("Unknown component name: %s."), name);
9281 lower = upper = ind;
9282 }
9283
9284 if (lower <= upper && (lower < low || upper > high))
9285 error (_("Index in component association out of bounds."));
9286
9287 add_component_interval (lower, upper, indices, num_indices,
9288 max_indices);
9289 while (lower <= upper)
9290 {
9291 int pos1;
5b4ee69b 9292
52ce6436
PH
9293 pos1 = expr_pc;
9294 assign_component (container, lhs, lower, exp, &pos1);
9295 lower += 1;
9296 }
9297 }
9298}
9299
9300/* Assign the value of the expression in the OP_OTHERS construct in
9301 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9302 have not been previously assigned. The index intervals already assigned
9303 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 9304 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9305static void
9306aggregate_assign_others (struct value *container,
9307 struct value *lhs, struct expression *exp,
9308 int *pos, LONGEST *indices, int num_indices,
9309 LONGEST low, LONGEST high)
9310{
9311 int i;
5ce64950 9312 int expr_pc = *pos + 1;
52ce6436
PH
9313
9314 for (i = 0; i < num_indices - 2; i += 2)
9315 {
9316 LONGEST ind;
5b4ee69b 9317
52ce6436
PH
9318 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9319 {
5ce64950 9320 int localpos;
5b4ee69b 9321
5ce64950
MS
9322 localpos = expr_pc;
9323 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
9324 }
9325 }
9326 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9327}
9328
9329/* Add the interval [LOW .. HIGH] to the sorted set of intervals
9330 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9331 modifying *SIZE as needed. It is an error if *SIZE exceeds
9332 MAX_SIZE. The resulting intervals do not overlap. */
9333static void
9334add_component_interval (LONGEST low, LONGEST high,
9335 LONGEST* indices, int *size, int max_size)
9336{
9337 int i, j;
5b4ee69b 9338
52ce6436
PH
9339 for (i = 0; i < *size; i += 2) {
9340 if (high >= indices[i] && low <= indices[i + 1])
9341 {
9342 int kh;
5b4ee69b 9343
52ce6436
PH
9344 for (kh = i + 2; kh < *size; kh += 2)
9345 if (high < indices[kh])
9346 break;
9347 if (low < indices[i])
9348 indices[i] = low;
9349 indices[i + 1] = indices[kh - 1];
9350 if (high > indices[i + 1])
9351 indices[i + 1] = high;
9352 memcpy (indices + i + 2, indices + kh, *size - kh);
9353 *size -= kh - i - 2;
9354 return;
9355 }
9356 else if (high < indices[i])
9357 break;
9358 }
9359
9360 if (*size == max_size)
9361 error (_("Internal error: miscounted aggregate components."));
9362 *size += 2;
9363 for (j = *size-1; j >= i+2; j -= 1)
9364 indices[j] = indices[j - 2];
9365 indices[i] = low;
9366 indices[i + 1] = high;
9367}
9368
6e48bd2c
JB
9369/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9370 is different. */
9371
9372static struct value *
9373ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
9374{
9375 if (type == ada_check_typedef (value_type (arg2)))
9376 return arg2;
9377
9378 if (ada_is_fixed_point_type (type))
9379 return (cast_to_fixed (type, arg2));
9380
9381 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9382 return cast_from_fixed (type, arg2);
6e48bd2c
JB
9383
9384 return value_cast (type, arg2);
9385}
9386
284614f0
JB
9387/* Evaluating Ada expressions, and printing their result.
9388 ------------------------------------------------------
9389
21649b50
JB
9390 1. Introduction:
9391 ----------------
9392
284614f0
JB
9393 We usually evaluate an Ada expression in order to print its value.
9394 We also evaluate an expression in order to print its type, which
9395 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9396 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9397 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9398 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9399 similar.
9400
9401 Evaluating expressions is a little more complicated for Ada entities
9402 than it is for entities in languages such as C. The main reason for
9403 this is that Ada provides types whose definition might be dynamic.
9404 One example of such types is variant records. Or another example
9405 would be an array whose bounds can only be known at run time.
9406
9407 The following description is a general guide as to what should be
9408 done (and what should NOT be done) in order to evaluate an expression
9409 involving such types, and when. This does not cover how the semantic
9410 information is encoded by GNAT as this is covered separatly. For the
9411 document used as the reference for the GNAT encoding, see exp_dbug.ads
9412 in the GNAT sources.
9413
9414 Ideally, we should embed each part of this description next to its
9415 associated code. Unfortunately, the amount of code is so vast right
9416 now that it's hard to see whether the code handling a particular
9417 situation might be duplicated or not. One day, when the code is
9418 cleaned up, this guide might become redundant with the comments
9419 inserted in the code, and we might want to remove it.
9420
21649b50
JB
9421 2. ``Fixing'' an Entity, the Simple Case:
9422 -----------------------------------------
9423
284614f0
JB
9424 When evaluating Ada expressions, the tricky issue is that they may
9425 reference entities whose type contents and size are not statically
9426 known. Consider for instance a variant record:
9427
9428 type Rec (Empty : Boolean := True) is record
9429 case Empty is
9430 when True => null;
9431 when False => Value : Integer;
9432 end case;
9433 end record;
9434 Yes : Rec := (Empty => False, Value => 1);
9435 No : Rec := (empty => True);
9436
9437 The size and contents of that record depends on the value of the
9438 descriminant (Rec.Empty). At this point, neither the debugging
9439 information nor the associated type structure in GDB are able to
9440 express such dynamic types. So what the debugger does is to create
9441 "fixed" versions of the type that applies to the specific object.
9442 We also informally refer to this opperation as "fixing" an object,
9443 which means creating its associated fixed type.
9444
9445 Example: when printing the value of variable "Yes" above, its fixed
9446 type would look like this:
9447
9448 type Rec is record
9449 Empty : Boolean;
9450 Value : Integer;
9451 end record;
9452
9453 On the other hand, if we printed the value of "No", its fixed type
9454 would become:
9455
9456 type Rec is record
9457 Empty : Boolean;
9458 end record;
9459
9460 Things become a little more complicated when trying to fix an entity
9461 with a dynamic type that directly contains another dynamic type,
9462 such as an array of variant records, for instance. There are
9463 two possible cases: Arrays, and records.
9464
21649b50
JB
9465 3. ``Fixing'' Arrays:
9466 ---------------------
9467
9468 The type structure in GDB describes an array in terms of its bounds,
9469 and the type of its elements. By design, all elements in the array
9470 have the same type and we cannot represent an array of variant elements
9471 using the current type structure in GDB. When fixing an array,
9472 we cannot fix the array element, as we would potentially need one
9473 fixed type per element of the array. As a result, the best we can do
9474 when fixing an array is to produce an array whose bounds and size
9475 are correct (allowing us to read it from memory), but without having
9476 touched its element type. Fixing each element will be done later,
9477 when (if) necessary.
9478
9479 Arrays are a little simpler to handle than records, because the same
9480 amount of memory is allocated for each element of the array, even if
1b536f04 9481 the amount of space actually used by each element differs from element
21649b50 9482 to element. Consider for instance the following array of type Rec:
284614f0
JB
9483
9484 type Rec_Array is array (1 .. 2) of Rec;
9485
1b536f04
JB
9486 The actual amount of memory occupied by each element might be different
9487 from element to element, depending on the value of their discriminant.
21649b50 9488 But the amount of space reserved for each element in the array remains
1b536f04 9489 fixed regardless. So we simply need to compute that size using
21649b50
JB
9490 the debugging information available, from which we can then determine
9491 the array size (we multiply the number of elements of the array by
9492 the size of each element).
9493
9494 The simplest case is when we have an array of a constrained element
9495 type. For instance, consider the following type declarations:
9496
9497 type Bounded_String (Max_Size : Integer) is
9498 Length : Integer;
9499 Buffer : String (1 .. Max_Size);
9500 end record;
9501 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9502
9503 In this case, the compiler describes the array as an array of
9504 variable-size elements (identified by its XVS suffix) for which
9505 the size can be read in the parallel XVZ variable.
9506
9507 In the case of an array of an unconstrained element type, the compiler
9508 wraps the array element inside a private PAD type. This type should not
9509 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
9510 that we also use the adjective "aligner" in our code to designate
9511 these wrapper types.
9512
1b536f04 9513 In some cases, the size allocated for each element is statically
21649b50
JB
9514 known. In that case, the PAD type already has the correct size,
9515 and the array element should remain unfixed.
9516
9517 But there are cases when this size is not statically known.
9518 For instance, assuming that "Five" is an integer variable:
284614f0
JB
9519
9520 type Dynamic is array (1 .. Five) of Integer;
9521 type Wrapper (Has_Length : Boolean := False) is record
9522 Data : Dynamic;
9523 case Has_Length is
9524 when True => Length : Integer;
9525 when False => null;
9526 end case;
9527 end record;
9528 type Wrapper_Array is array (1 .. 2) of Wrapper;
9529
9530 Hello : Wrapper_Array := (others => (Has_Length => True,
9531 Data => (others => 17),
9532 Length => 1));
9533
9534
9535 The debugging info would describe variable Hello as being an
9536 array of a PAD type. The size of that PAD type is not statically
9537 known, but can be determined using a parallel XVZ variable.
9538 In that case, a copy of the PAD type with the correct size should
9539 be used for the fixed array.
9540
21649b50
JB
9541 3. ``Fixing'' record type objects:
9542 ----------------------------------
9543
9544 Things are slightly different from arrays in the case of dynamic
284614f0
JB
9545 record types. In this case, in order to compute the associated
9546 fixed type, we need to determine the size and offset of each of
9547 its components. This, in turn, requires us to compute the fixed
9548 type of each of these components.
9549
9550 Consider for instance the example:
9551
9552 type Bounded_String (Max_Size : Natural) is record
9553 Str : String (1 .. Max_Size);
9554 Length : Natural;
9555 end record;
9556 My_String : Bounded_String (Max_Size => 10);
9557
9558 In that case, the position of field "Length" depends on the size
9559 of field Str, which itself depends on the value of the Max_Size
21649b50 9560 discriminant. In order to fix the type of variable My_String,
284614f0
JB
9561 we need to fix the type of field Str. Therefore, fixing a variant
9562 record requires us to fix each of its components.
9563
9564 However, if a component does not have a dynamic size, the component
9565 should not be fixed. In particular, fields that use a PAD type
9566 should not fixed. Here is an example where this might happen
9567 (assuming type Rec above):
9568
9569 type Container (Big : Boolean) is record
9570 First : Rec;
9571 After : Integer;
9572 case Big is
9573 when True => Another : Integer;
9574 when False => null;
9575 end case;
9576 end record;
9577 My_Container : Container := (Big => False,
9578 First => (Empty => True),
9579 After => 42);
9580
9581 In that example, the compiler creates a PAD type for component First,
9582 whose size is constant, and then positions the component After just
9583 right after it. The offset of component After is therefore constant
9584 in this case.
9585
9586 The debugger computes the position of each field based on an algorithm
9587 that uses, among other things, the actual position and size of the field
21649b50
JB
9588 preceding it. Let's now imagine that the user is trying to print
9589 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
9590 end up computing the offset of field After based on the size of the
9591 fixed version of field First. And since in our example First has
9592 only one actual field, the size of the fixed type is actually smaller
9593 than the amount of space allocated to that field, and thus we would
9594 compute the wrong offset of field After.
9595
21649b50
JB
9596 To make things more complicated, we need to watch out for dynamic
9597 components of variant records (identified by the ___XVL suffix in
9598 the component name). Even if the target type is a PAD type, the size
9599 of that type might not be statically known. So the PAD type needs
9600 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9601 we might end up with the wrong size for our component. This can be
9602 observed with the following type declarations:
284614f0
JB
9603
9604 type Octal is new Integer range 0 .. 7;
9605 type Octal_Array is array (Positive range <>) of Octal;
9606 pragma Pack (Octal_Array);
9607
9608 type Octal_Buffer (Size : Positive) is record
9609 Buffer : Octal_Array (1 .. Size);
9610 Length : Integer;
9611 end record;
9612
9613 In that case, Buffer is a PAD type whose size is unset and needs
9614 to be computed by fixing the unwrapped type.
9615
21649b50
JB
9616 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9617 ----------------------------------------------------------
9618
9619 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
9620 thus far, be actually fixed?
9621
9622 The answer is: Only when referencing that element. For instance
9623 when selecting one component of a record, this specific component
9624 should be fixed at that point in time. Or when printing the value
9625 of a record, each component should be fixed before its value gets
9626 printed. Similarly for arrays, the element of the array should be
9627 fixed when printing each element of the array, or when extracting
9628 one element out of that array. On the other hand, fixing should
9629 not be performed on the elements when taking a slice of an array!
9630
9631 Note that one of the side-effects of miscomputing the offset and
9632 size of each field is that we end up also miscomputing the size
9633 of the containing type. This can have adverse results when computing
9634 the value of an entity. GDB fetches the value of an entity based
9635 on the size of its type, and thus a wrong size causes GDB to fetch
9636 the wrong amount of memory. In the case where the computed size is
9637 too small, GDB fetches too little data to print the value of our
9638 entiry. Results in this case as unpredicatble, as we usually read
9639 past the buffer containing the data =:-o. */
9640
9641/* Implement the evaluate_exp routine in the exp_descriptor structure
9642 for the Ada language. */
9643
52ce6436 9644static struct value *
ebf56fd3 9645ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 9646 int *pos, enum noside noside)
14f9c5c9
AS
9647{
9648 enum exp_opcode op;
b5385fc0 9649 int tem;
14f9c5c9
AS
9650 int pc;
9651 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
9652 struct type *type;
52ce6436 9653 int nargs, oplen;
d2e4a39e 9654 struct value **argvec;
14f9c5c9 9655
d2e4a39e
AS
9656 pc = *pos;
9657 *pos += 1;
14f9c5c9
AS
9658 op = exp->elts[pc].opcode;
9659
d2e4a39e 9660 switch (op)
14f9c5c9
AS
9661 {
9662 default:
9663 *pos -= 1;
6e48bd2c 9664 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
9665
9666 if (noside == EVAL_NORMAL)
9667 arg1 = unwrap_value (arg1);
6e48bd2c
JB
9668
9669 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
9670 then we need to perform the conversion manually, because
9671 evaluate_subexp_standard doesn't do it. This conversion is
9672 necessary in Ada because the different kinds of float/fixed
9673 types in Ada have different representations.
9674
9675 Similarly, we need to perform the conversion from OP_LONG
9676 ourselves. */
9677 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
9678 arg1 = ada_value_cast (expect_type, arg1, noside);
9679
9680 return arg1;
4c4b4cd2
PH
9681
9682 case OP_STRING:
9683 {
76a01679 9684 struct value *result;
5b4ee69b 9685
76a01679
JB
9686 *pos -= 1;
9687 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
9688 /* The result type will have code OP_STRING, bashed there from
9689 OP_ARRAY. Bash it back. */
df407dfe
AC
9690 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
9691 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 9692 return result;
4c4b4cd2 9693 }
14f9c5c9
AS
9694
9695 case UNOP_CAST:
9696 (*pos) += 2;
9697 type = exp->elts[pc + 1].type;
9698 arg1 = evaluate_subexp (type, exp, pos, noside);
9699 if (noside == EVAL_SKIP)
4c4b4cd2 9700 goto nosideret;
6e48bd2c 9701 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
9702 return arg1;
9703
4c4b4cd2
PH
9704 case UNOP_QUAL:
9705 (*pos) += 2;
9706 type = exp->elts[pc + 1].type;
9707 return ada_evaluate_subexp (type, exp, pos, noside);
9708
14f9c5c9
AS
9709 case BINOP_ASSIGN:
9710 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
9711 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9712 {
9713 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
9714 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
9715 return arg1;
9716 return ada_value_assign (arg1, arg1);
9717 }
003f3813
JB
9718 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9719 except if the lhs of our assignment is a convenience variable.
9720 In the case of assigning to a convenience variable, the lhs
9721 should be exactly the result of the evaluation of the rhs. */
9722 type = value_type (arg1);
9723 if (VALUE_LVAL (arg1) == lval_internalvar)
9724 type = NULL;
9725 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 9726 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 9727 return arg1;
df407dfe
AC
9728 if (ada_is_fixed_point_type (value_type (arg1)))
9729 arg2 = cast_to_fixed (value_type (arg1), arg2);
9730 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 9731 error
323e0a4a 9732 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 9733 else
df407dfe 9734 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 9735 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
9736
9737 case BINOP_ADD:
9738 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9739 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9740 if (noside == EVAL_SKIP)
4c4b4cd2 9741 goto nosideret;
2ac8a782
JB
9742 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9743 return (value_from_longest
9744 (value_type (arg1),
9745 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
9746 if ((ada_is_fixed_point_type (value_type (arg1))
9747 || ada_is_fixed_point_type (value_type (arg2)))
9748 && value_type (arg1) != value_type (arg2))
323e0a4a 9749 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
9750 /* Do the addition, and cast the result to the type of the first
9751 argument. We cannot cast the result to a reference type, so if
9752 ARG1 is a reference type, find its underlying type. */
9753 type = value_type (arg1);
9754 while (TYPE_CODE (type) == TYPE_CODE_REF)
9755 type = TYPE_TARGET_TYPE (type);
f44316fa 9756 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 9757 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
9758
9759 case BINOP_SUB:
9760 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9761 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9762 if (noside == EVAL_SKIP)
4c4b4cd2 9763 goto nosideret;
2ac8a782
JB
9764 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9765 return (value_from_longest
9766 (value_type (arg1),
9767 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
9768 if ((ada_is_fixed_point_type (value_type (arg1))
9769 || ada_is_fixed_point_type (value_type (arg2)))
9770 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
9771 error (_("Operands of fixed-point subtraction "
9772 "must have the same type"));
b7789565
JB
9773 /* Do the substraction, and cast the result to the type of the first
9774 argument. We cannot cast the result to a reference type, so if
9775 ARG1 is a reference type, find its underlying type. */
9776 type = value_type (arg1);
9777 while (TYPE_CODE (type) == TYPE_CODE_REF)
9778 type = TYPE_TARGET_TYPE (type);
f44316fa 9779 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 9780 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
9781
9782 case BINOP_MUL:
9783 case BINOP_DIV:
e1578042
JB
9784 case BINOP_REM:
9785 case BINOP_MOD:
14f9c5c9
AS
9786 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9787 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9788 if (noside == EVAL_SKIP)
4c4b4cd2 9789 goto nosideret;
e1578042 9790 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
9791 {
9792 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9793 return value_zero (value_type (arg1), not_lval);
9794 }
14f9c5c9 9795 else
4c4b4cd2 9796 {
a53b7a21 9797 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 9798 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 9799 arg1 = cast_from_fixed (type, arg1);
df407dfe 9800 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9801 arg2 = cast_from_fixed (type, arg2);
f44316fa 9802 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
9803 return ada_value_binop (arg1, arg2, op);
9804 }
9805
4c4b4cd2
PH
9806 case BINOP_EQUAL:
9807 case BINOP_NOTEQUAL:
14f9c5c9 9808 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 9809 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 9810 if (noside == EVAL_SKIP)
76a01679 9811 goto nosideret;
4c4b4cd2 9812 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9813 tem = 0;
4c4b4cd2 9814 else
f44316fa
UW
9815 {
9816 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9817 tem = ada_value_equal (arg1, arg2);
9818 }
4c4b4cd2 9819 if (op == BINOP_NOTEQUAL)
76a01679 9820 tem = !tem;
fbb06eb1
UW
9821 type = language_bool_type (exp->language_defn, exp->gdbarch);
9822 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
9823
9824 case UNOP_NEG:
9825 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9826 if (noside == EVAL_SKIP)
9827 goto nosideret;
df407dfe
AC
9828 else if (ada_is_fixed_point_type (value_type (arg1)))
9829 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 9830 else
f44316fa
UW
9831 {
9832 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9833 return value_neg (arg1);
9834 }
4c4b4cd2 9835
2330c6c6
JB
9836 case BINOP_LOGICAL_AND:
9837 case BINOP_LOGICAL_OR:
9838 case UNOP_LOGICAL_NOT:
000d5124
JB
9839 {
9840 struct value *val;
9841
9842 *pos -= 1;
9843 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
9844 type = language_bool_type (exp->language_defn, exp->gdbarch);
9845 return value_cast (type, val);
000d5124 9846 }
2330c6c6
JB
9847
9848 case BINOP_BITWISE_AND:
9849 case BINOP_BITWISE_IOR:
9850 case BINOP_BITWISE_XOR:
000d5124
JB
9851 {
9852 struct value *val;
9853
9854 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
9855 *pos = pc;
9856 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
9857
9858 return value_cast (value_type (arg1), val);
9859 }
2330c6c6 9860
14f9c5c9
AS
9861 case OP_VAR_VALUE:
9862 *pos -= 1;
6799def4 9863
14f9c5c9 9864 if (noside == EVAL_SKIP)
4c4b4cd2
PH
9865 {
9866 *pos += 4;
9867 goto nosideret;
9868 }
9869 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
9870 /* Only encountered when an unresolved symbol occurs in a
9871 context other than a function call, in which case, it is
52ce6436 9872 invalid. */
323e0a4a 9873 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 9874 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
14f9c5c9 9875 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 9876 {
0c1f74cf 9877 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
9878 /* Check to see if this is a tagged type. We also need to handle
9879 the case where the type is a reference to a tagged type, but
9880 we have to be careful to exclude pointers to tagged types.
9881 The latter should be shown as usual (as a pointer), whereas
9882 a reference should mostly be transparent to the user. */
9883 if (ada_is_tagged_type (type, 0)
9884 || (TYPE_CODE(type) == TYPE_CODE_REF
9885 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0c1f74cf
JB
9886 {
9887 /* Tagged types are a little special in the fact that the real
9888 type is dynamic and can only be determined by inspecting the
9889 object's tag. This means that we need to get the object's
9890 value first (EVAL_NORMAL) and then extract the actual object
9891 type from its tag.
9892
9893 Note that we cannot skip the final step where we extract
9894 the object type from its tag, because the EVAL_NORMAL phase
9895 results in dynamic components being resolved into fixed ones.
9896 This can cause problems when trying to print the type
9897 description of tagged types whose parent has a dynamic size:
9898 We use the type name of the "_parent" component in order
9899 to print the name of the ancestor type in the type description.
9900 If that component had a dynamic size, the resolution into
9901 a fixed type would result in the loss of that type name,
9902 thus preventing us from printing the name of the ancestor
9903 type in the type description. */
9904 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
b50d69b5
JG
9905
9906 if (TYPE_CODE (type) != TYPE_CODE_REF)
9907 {
9908 struct type *actual_type;
9909
9910 actual_type = type_from_tag (ada_value_tag (arg1));
9911 if (actual_type == NULL)
9912 /* If, for some reason, we were unable to determine
9913 the actual type from the tag, then use the static
9914 approximation that we just computed as a fallback.
9915 This can happen if the debugging information is
9916 incomplete, for instance. */
9917 actual_type = type;
9918 return value_zero (actual_type, not_lval);
9919 }
9920 else
9921 {
9922 /* In the case of a ref, ada_coerce_ref takes care
9923 of determining the actual type. But the evaluation
9924 should return a ref as it should be valid to ask
9925 for its address; so rebuild a ref after coerce. */
9926 arg1 = ada_coerce_ref (arg1);
9927 return value_ref (arg1);
9928 }
0c1f74cf
JB
9929 }
9930
4c4b4cd2
PH
9931 *pos += 4;
9932 return value_zero
9933 (to_static_fixed_type
9934 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
9935 not_lval);
9936 }
d2e4a39e 9937 else
4c4b4cd2 9938 {
284614f0 9939 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
4c4b4cd2
PH
9940 return ada_to_fixed_value (arg1);
9941 }
9942
9943 case OP_FUNCALL:
9944 (*pos) += 2;
9945
9946 /* Allocate arg vector, including space for the function to be
9947 called in argvec[0] and a terminating NULL. */
9948 nargs = longest_to_int (exp->elts[pc + 1].longconst);
9949 argvec =
9950 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
9951
9952 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 9953 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 9954 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
9955 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
9956 else
9957 {
9958 for (tem = 0; tem <= nargs; tem += 1)
9959 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9960 argvec[tem] = 0;
9961
9962 if (noside == EVAL_SKIP)
9963 goto nosideret;
9964 }
9965
ad82864c
JB
9966 if (ada_is_constrained_packed_array_type
9967 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 9968 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
9969 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
9970 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
9971 /* This is a packed array that has already been fixed, and
9972 therefore already coerced to a simple array. Nothing further
9973 to do. */
9974 ;
df407dfe
AC
9975 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
9976 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
76a01679 9977 && VALUE_LVAL (argvec[0]) == lval_memory))
4c4b4cd2
PH
9978 argvec[0] = value_addr (argvec[0]);
9979
df407dfe 9980 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
9981
9982 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
9983 them. So, if this is an array typedef (encoding use for array
9984 access types encoded as fat pointers), strip it now. */
720d1a40
JB
9985 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
9986 type = ada_typedef_target_type (type);
9987
4c4b4cd2
PH
9988 if (TYPE_CODE (type) == TYPE_CODE_PTR)
9989 {
61ee279c 9990 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
9991 {
9992 case TYPE_CODE_FUNC:
61ee279c 9993 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
9994 break;
9995 case TYPE_CODE_ARRAY:
9996 break;
9997 case TYPE_CODE_STRUCT:
9998 if (noside != EVAL_AVOID_SIDE_EFFECTS)
9999 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10000 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10001 break;
10002 default:
323e0a4a 10003 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10004 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10005 break;
10006 }
10007 }
10008
10009 switch (TYPE_CODE (type))
10010 {
10011 case TYPE_CODE_FUNC:
10012 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972
PH
10013 {
10014 struct type *rtype = TYPE_TARGET_TYPE (type);
10015
10016 if (TYPE_GNU_IFUNC (type))
10017 return allocate_value (TYPE_TARGET_TYPE (rtype));
10018 return allocate_value (rtype);
10019 }
4c4b4cd2 10020 return call_function_by_hand (argvec[0], nargs, argvec + 1);
c8ea1972
PH
10021 case TYPE_CODE_INTERNAL_FUNCTION:
10022 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10023 /* We don't know anything about what the internal
10024 function might return, but we have to return
10025 something. */
10026 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10027 not_lval);
10028 else
10029 return call_internal_function (exp->gdbarch, exp->language_defn,
10030 argvec[0], nargs, argvec + 1);
10031
4c4b4cd2
PH
10032 case TYPE_CODE_STRUCT:
10033 {
10034 int arity;
10035
4c4b4cd2
PH
10036 arity = ada_array_arity (type);
10037 type = ada_array_element_type (type, nargs);
10038 if (type == NULL)
323e0a4a 10039 error (_("cannot subscript or call a record"));
4c4b4cd2 10040 if (arity != nargs)
323e0a4a 10041 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10042 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10043 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10044 return
10045 unwrap_value (ada_value_subscript
10046 (argvec[0], nargs, argvec + 1));
10047 }
10048 case TYPE_CODE_ARRAY:
10049 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10050 {
10051 type = ada_array_element_type (type, nargs);
10052 if (type == NULL)
323e0a4a 10053 error (_("element type of array unknown"));
4c4b4cd2 10054 else
0a07e705 10055 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10056 }
10057 return
10058 unwrap_value (ada_value_subscript
10059 (ada_coerce_to_simple_array (argvec[0]),
10060 nargs, argvec + 1));
10061 case TYPE_CODE_PTR: /* Pointer to array */
10062 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10063 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10064 {
10065 type = ada_array_element_type (type, nargs);
10066 if (type == NULL)
323e0a4a 10067 error (_("element type of array unknown"));
4c4b4cd2 10068 else
0a07e705 10069 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10070 }
10071 return
10072 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
10073 nargs, argvec + 1));
10074
10075 default:
e1d5a0d2
PH
10076 error (_("Attempt to index or call something other than an "
10077 "array or function"));
4c4b4cd2
PH
10078 }
10079
10080 case TERNOP_SLICE:
10081 {
10082 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10083 struct value *low_bound_val =
10084 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
10085 struct value *high_bound_val =
10086 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10087 LONGEST low_bound;
10088 LONGEST high_bound;
5b4ee69b 10089
994b9211
AC
10090 low_bound_val = coerce_ref (low_bound_val);
10091 high_bound_val = coerce_ref (high_bound_val);
714e53ab
PH
10092 low_bound = pos_atr (low_bound_val);
10093 high_bound = pos_atr (high_bound_val);
963a6417 10094
4c4b4cd2
PH
10095 if (noside == EVAL_SKIP)
10096 goto nosideret;
10097
4c4b4cd2
PH
10098 /* If this is a reference to an aligner type, then remove all
10099 the aligners. */
df407dfe
AC
10100 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10101 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10102 TYPE_TARGET_TYPE (value_type (array)) =
10103 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 10104
ad82864c 10105 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 10106 error (_("cannot slice a packed array"));
4c4b4cd2
PH
10107
10108 /* If this is a reference to an array or an array lvalue,
10109 convert to a pointer. */
df407dfe
AC
10110 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10111 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
10112 && VALUE_LVAL (array) == lval_memory))
10113 array = value_addr (array);
10114
1265e4aa 10115 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 10116 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 10117 (value_type (array))))
0b5d8877 10118 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
10119
10120 array = ada_coerce_to_simple_array_ptr (array);
10121
714e53ab
PH
10122 /* If we have more than one level of pointer indirection,
10123 dereference the value until we get only one level. */
df407dfe
AC
10124 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10125 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
10126 == TYPE_CODE_PTR))
10127 array = value_ind (array);
10128
10129 /* Make sure we really do have an array type before going further,
10130 to avoid a SEGV when trying to get the index type or the target
10131 type later down the road if the debug info generated by
10132 the compiler is incorrect or incomplete. */
df407dfe 10133 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 10134 error (_("cannot take slice of non-array"));
714e53ab 10135
828292f2
JB
10136 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10137 == TYPE_CODE_PTR)
4c4b4cd2 10138 {
828292f2
JB
10139 struct type *type0 = ada_check_typedef (value_type (array));
10140
0b5d8877 10141 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 10142 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
10143 else
10144 {
10145 struct type *arr_type0 =
828292f2 10146 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 10147
f5938064
JG
10148 return ada_value_slice_from_ptr (array, arr_type0,
10149 longest_to_int (low_bound),
10150 longest_to_int (high_bound));
4c4b4cd2
PH
10151 }
10152 }
10153 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10154 return array;
10155 else if (high_bound < low_bound)
df407dfe 10156 return empty_array (value_type (array), low_bound);
4c4b4cd2 10157 else
529cad9c
PH
10158 return ada_value_slice (array, longest_to_int (low_bound),
10159 longest_to_int (high_bound));
4c4b4cd2 10160 }
14f9c5c9 10161
4c4b4cd2
PH
10162 case UNOP_IN_RANGE:
10163 (*pos) += 2;
10164 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 10165 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 10166
14f9c5c9 10167 if (noside == EVAL_SKIP)
4c4b4cd2 10168 goto nosideret;
14f9c5c9 10169
4c4b4cd2
PH
10170 switch (TYPE_CODE (type))
10171 {
10172 default:
e1d5a0d2
PH
10173 lim_warning (_("Membership test incompletely implemented; "
10174 "always returns true"));
fbb06eb1
UW
10175 type = language_bool_type (exp->language_defn, exp->gdbarch);
10176 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
10177
10178 case TYPE_CODE_RANGE:
030b4912
UW
10179 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10180 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
10181 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10182 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
10183 type = language_bool_type (exp->language_defn, exp->gdbarch);
10184 return
10185 value_from_longest (type,
4c4b4cd2
PH
10186 (value_less (arg1, arg3)
10187 || value_equal (arg1, arg3))
10188 && (value_less (arg2, arg1)
10189 || value_equal (arg2, arg1)));
10190 }
10191
10192 case BINOP_IN_BOUNDS:
14f9c5c9 10193 (*pos) += 2;
4c4b4cd2
PH
10194 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10195 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10196
4c4b4cd2
PH
10197 if (noside == EVAL_SKIP)
10198 goto nosideret;
14f9c5c9 10199
4c4b4cd2 10200 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
10201 {
10202 type = language_bool_type (exp->language_defn, exp->gdbarch);
10203 return value_zero (type, not_lval);
10204 }
14f9c5c9 10205
4c4b4cd2 10206 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 10207
1eea4ebd
UW
10208 type = ada_index_type (value_type (arg2), tem, "range");
10209 if (!type)
10210 type = value_type (arg1);
14f9c5c9 10211
1eea4ebd
UW
10212 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10213 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 10214
f44316fa
UW
10215 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10216 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10217 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10218 return
fbb06eb1 10219 value_from_longest (type,
4c4b4cd2
PH
10220 (value_less (arg1, arg3)
10221 || value_equal (arg1, arg3))
10222 && (value_less (arg2, arg1)
10223 || value_equal (arg2, arg1)));
10224
10225 case TERNOP_IN_RANGE:
10226 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10227 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10228 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10229
10230 if (noside == EVAL_SKIP)
10231 goto nosideret;
10232
f44316fa
UW
10233 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10234 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10235 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10236 return
fbb06eb1 10237 value_from_longest (type,
4c4b4cd2
PH
10238 (value_less (arg1, arg3)
10239 || value_equal (arg1, arg3))
10240 && (value_less (arg2, arg1)
10241 || value_equal (arg2, arg1)));
10242
10243 case OP_ATR_FIRST:
10244 case OP_ATR_LAST:
10245 case OP_ATR_LENGTH:
10246 {
76a01679 10247 struct type *type_arg;
5b4ee69b 10248
76a01679
JB
10249 if (exp->elts[*pos].opcode == OP_TYPE)
10250 {
10251 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10252 arg1 = NULL;
5bc23cb3 10253 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
10254 }
10255 else
10256 {
10257 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10258 type_arg = NULL;
10259 }
10260
10261 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 10262 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
10263 tem = longest_to_int (exp->elts[*pos + 2].longconst);
10264 *pos += 4;
10265
10266 if (noside == EVAL_SKIP)
10267 goto nosideret;
10268
10269 if (type_arg == NULL)
10270 {
10271 arg1 = ada_coerce_ref (arg1);
10272
ad82864c 10273 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
10274 arg1 = ada_coerce_to_simple_array (arg1);
10275
1eea4ebd
UW
10276 type = ada_index_type (value_type (arg1), tem,
10277 ada_attribute_name (op));
10278 if (type == NULL)
10279 type = builtin_type (exp->gdbarch)->builtin_int;
76a01679
JB
10280
10281 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 10282 return allocate_value (type);
76a01679
JB
10283
10284 switch (op)
10285 {
10286 default: /* Should never happen. */
323e0a4a 10287 error (_("unexpected attribute encountered"));
76a01679 10288 case OP_ATR_FIRST:
1eea4ebd
UW
10289 return value_from_longest
10290 (type, ada_array_bound (arg1, tem, 0));
76a01679 10291 case OP_ATR_LAST:
1eea4ebd
UW
10292 return value_from_longest
10293 (type, ada_array_bound (arg1, tem, 1));
76a01679 10294 case OP_ATR_LENGTH:
1eea4ebd
UW
10295 return value_from_longest
10296 (type, ada_array_length (arg1, tem));
76a01679
JB
10297 }
10298 }
10299 else if (discrete_type_p (type_arg))
10300 {
10301 struct type *range_type;
0d5cff50 10302 const char *name = ada_type_name (type_arg);
5b4ee69b 10303
76a01679
JB
10304 range_type = NULL;
10305 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 10306 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
10307 if (range_type == NULL)
10308 range_type = type_arg;
10309 switch (op)
10310 {
10311 default:
323e0a4a 10312 error (_("unexpected attribute encountered"));
76a01679 10313 case OP_ATR_FIRST:
690cc4eb 10314 return value_from_longest
43bbcdc2 10315 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 10316 case OP_ATR_LAST:
690cc4eb 10317 return value_from_longest
43bbcdc2 10318 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 10319 case OP_ATR_LENGTH:
323e0a4a 10320 error (_("the 'length attribute applies only to array types"));
76a01679
JB
10321 }
10322 }
10323 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 10324 error (_("unimplemented type attribute"));
76a01679
JB
10325 else
10326 {
10327 LONGEST low, high;
10328
ad82864c
JB
10329 if (ada_is_constrained_packed_array_type (type_arg))
10330 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 10331
1eea4ebd 10332 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
76a01679 10333 if (type == NULL)
1eea4ebd
UW
10334 type = builtin_type (exp->gdbarch)->builtin_int;
10335
76a01679
JB
10336 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10337 return allocate_value (type);
10338
10339 switch (op)
10340 {
10341 default:
323e0a4a 10342 error (_("unexpected attribute encountered"));
76a01679 10343 case OP_ATR_FIRST:
1eea4ebd 10344 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
10345 return value_from_longest (type, low);
10346 case OP_ATR_LAST:
1eea4ebd 10347 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10348 return value_from_longest (type, high);
10349 case OP_ATR_LENGTH:
1eea4ebd
UW
10350 low = ada_array_bound_from_type (type_arg, tem, 0);
10351 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10352 return value_from_longest (type, high - low + 1);
10353 }
10354 }
14f9c5c9
AS
10355 }
10356
4c4b4cd2
PH
10357 case OP_ATR_TAG:
10358 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10359 if (noside == EVAL_SKIP)
76a01679 10360 goto nosideret;
4c4b4cd2
PH
10361
10362 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10363 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
10364
10365 return ada_value_tag (arg1);
10366
10367 case OP_ATR_MIN:
10368 case OP_ATR_MAX:
10369 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10370 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10371 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10372 if (noside == EVAL_SKIP)
76a01679 10373 goto nosideret;
d2e4a39e 10374 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10375 return value_zero (value_type (arg1), not_lval);
14f9c5c9 10376 else
f44316fa
UW
10377 {
10378 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10379 return value_binop (arg1, arg2,
10380 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
10381 }
14f9c5c9 10382
4c4b4cd2
PH
10383 case OP_ATR_MODULUS:
10384 {
31dedfee 10385 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 10386
5b4ee69b 10387 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
10388 if (noside == EVAL_SKIP)
10389 goto nosideret;
4c4b4cd2 10390
76a01679 10391 if (!ada_is_modular_type (type_arg))
323e0a4a 10392 error (_("'modulus must be applied to modular type"));
4c4b4cd2 10393
76a01679
JB
10394 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
10395 ada_modulus (type_arg));
4c4b4cd2
PH
10396 }
10397
10398
10399 case OP_ATR_POS:
10400 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10401 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10402 if (noside == EVAL_SKIP)
76a01679 10403 goto nosideret;
3cb382c9
UW
10404 type = builtin_type (exp->gdbarch)->builtin_int;
10405 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10406 return value_zero (type, not_lval);
14f9c5c9 10407 else
3cb382c9 10408 return value_pos_atr (type, arg1);
14f9c5c9 10409
4c4b4cd2
PH
10410 case OP_ATR_SIZE:
10411 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
10412 type = value_type (arg1);
10413
10414 /* If the argument is a reference, then dereference its type, since
10415 the user is really asking for the size of the actual object,
10416 not the size of the pointer. */
10417 if (TYPE_CODE (type) == TYPE_CODE_REF)
10418 type = TYPE_TARGET_TYPE (type);
10419
4c4b4cd2 10420 if (noside == EVAL_SKIP)
76a01679 10421 goto nosideret;
4c4b4cd2 10422 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 10423 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 10424 else
22601c15 10425 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 10426 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
10427
10428 case OP_ATR_VAL:
10429 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 10430 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 10431 type = exp->elts[pc + 2].type;
14f9c5c9 10432 if (noside == EVAL_SKIP)
76a01679 10433 goto nosideret;
4c4b4cd2 10434 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10435 return value_zero (type, not_lval);
4c4b4cd2 10436 else
76a01679 10437 return value_val_atr (type, arg1);
4c4b4cd2
PH
10438
10439 case BINOP_EXP:
10440 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10441 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10442 if (noside == EVAL_SKIP)
10443 goto nosideret;
10444 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10445 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 10446 else
f44316fa
UW
10447 {
10448 /* For integer exponentiation operations,
10449 only promote the first argument. */
10450 if (is_integral_type (value_type (arg2)))
10451 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10452 else
10453 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10454
10455 return value_binop (arg1, arg2, op);
10456 }
4c4b4cd2
PH
10457
10458 case UNOP_PLUS:
10459 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10460 if (noside == EVAL_SKIP)
10461 goto nosideret;
10462 else
10463 return arg1;
10464
10465 case UNOP_ABS:
10466 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10467 if (noside == EVAL_SKIP)
10468 goto nosideret;
f44316fa 10469 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 10470 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 10471 return value_neg (arg1);
14f9c5c9 10472 else
4c4b4cd2 10473 return arg1;
14f9c5c9
AS
10474
10475 case UNOP_IND:
6b0d7253 10476 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10477 if (noside == EVAL_SKIP)
4c4b4cd2 10478 goto nosideret;
df407dfe 10479 type = ada_check_typedef (value_type (arg1));
14f9c5c9 10480 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
10481 {
10482 if (ada_is_array_descriptor_type (type))
10483 /* GDB allows dereferencing GNAT array descriptors. */
10484 {
10485 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 10486
4c4b4cd2 10487 if (arrType == NULL)
323e0a4a 10488 error (_("Attempt to dereference null array pointer."));
00a4c844 10489 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
10490 }
10491 else if (TYPE_CODE (type) == TYPE_CODE_PTR
10492 || TYPE_CODE (type) == TYPE_CODE_REF
10493 /* In C you can dereference an array to get the 1st elt. */
10494 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab
PH
10495 {
10496 type = to_static_fixed_type
10497 (ada_aligned_type
10498 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10499 check_size (type);
10500 return value_zero (type, lval_memory);
10501 }
4c4b4cd2 10502 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
10503 {
10504 /* GDB allows dereferencing an int. */
10505 if (expect_type == NULL)
10506 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10507 lval_memory);
10508 else
10509 {
10510 expect_type =
10511 to_static_fixed_type (ada_aligned_type (expect_type));
10512 return value_zero (expect_type, lval_memory);
10513 }
10514 }
4c4b4cd2 10515 else
323e0a4a 10516 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 10517 }
0963b4bd 10518 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 10519 type = ada_check_typedef (value_type (arg1));
d2e4a39e 10520
96967637
JB
10521 if (TYPE_CODE (type) == TYPE_CODE_INT)
10522 /* GDB allows dereferencing an int. If we were given
10523 the expect_type, then use that as the target type.
10524 Otherwise, assume that the target type is an int. */
10525 {
10526 if (expect_type != NULL)
10527 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10528 arg1));
10529 else
10530 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10531 (CORE_ADDR) value_as_address (arg1));
10532 }
6b0d7253 10533
4c4b4cd2
PH
10534 if (ada_is_array_descriptor_type (type))
10535 /* GDB allows dereferencing GNAT array descriptors. */
10536 return ada_coerce_to_simple_array (arg1);
14f9c5c9 10537 else
4c4b4cd2 10538 return ada_value_ind (arg1);
14f9c5c9
AS
10539
10540 case STRUCTOP_STRUCT:
10541 tem = longest_to_int (exp->elts[pc + 1].longconst);
10542 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
10543 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10544 if (noside == EVAL_SKIP)
4c4b4cd2 10545 goto nosideret;
14f9c5c9 10546 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10547 {
df407dfe 10548 struct type *type1 = value_type (arg1);
5b4ee69b 10549
76a01679
JB
10550 if (ada_is_tagged_type (type1, 1))
10551 {
10552 type = ada_lookup_struct_elt_type (type1,
10553 &exp->elts[pc + 2].string,
10554 1, 1, NULL);
10555 if (type == NULL)
10556 /* In this case, we assume that the field COULD exist
10557 in some extension of the type. Return an object of
10558 "type" void, which will match any formal
0963b4bd 10559 (see ada_type_match). */
30b15541
UW
10560 return value_zero (builtin_type (exp->gdbarch)->builtin_void,
10561 lval_memory);
76a01679
JB
10562 }
10563 else
10564 type =
10565 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
10566 0, NULL);
10567
10568 return value_zero (ada_aligned_type (type), lval_memory);
10569 }
14f9c5c9 10570 else
284614f0
JB
10571 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
10572 arg1 = unwrap_value (arg1);
10573 return ada_to_fixed_value (arg1);
10574
14f9c5c9 10575 case OP_TYPE:
4c4b4cd2
PH
10576 /* The value is not supposed to be used. This is here to make it
10577 easier to accommodate expressions that contain types. */
14f9c5c9
AS
10578 (*pos) += 2;
10579 if (noside == EVAL_SKIP)
4c4b4cd2 10580 goto nosideret;
14f9c5c9 10581 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 10582 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 10583 else
323e0a4a 10584 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
10585
10586 case OP_AGGREGATE:
10587 case OP_CHOICES:
10588 case OP_OTHERS:
10589 case OP_DISCRETE_RANGE:
10590 case OP_POSITIONAL:
10591 case OP_NAME:
10592 if (noside == EVAL_NORMAL)
10593 switch (op)
10594 {
10595 case OP_NAME:
10596 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 10597 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
10598 case OP_AGGREGATE:
10599 error (_("Aggregates only allowed on the right of an assignment"));
10600 default:
0963b4bd
MS
10601 internal_error (__FILE__, __LINE__,
10602 _("aggregate apparently mangled"));
52ce6436
PH
10603 }
10604
10605 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10606 *pos += oplen - 1;
10607 for (tem = 0; tem < nargs; tem += 1)
10608 ada_evaluate_subexp (NULL, exp, pos, noside);
10609 goto nosideret;
14f9c5c9
AS
10610 }
10611
10612nosideret:
22601c15 10613 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
14f9c5c9 10614}
14f9c5c9 10615\f
d2e4a39e 10616
4c4b4cd2 10617 /* Fixed point */
14f9c5c9
AS
10618
10619/* If TYPE encodes an Ada fixed-point type, return the suffix of the
10620 type name that encodes the 'small and 'delta information.
4c4b4cd2 10621 Otherwise, return NULL. */
14f9c5c9 10622
d2e4a39e 10623static const char *
ebf56fd3 10624fixed_type_info (struct type *type)
14f9c5c9 10625{
d2e4a39e 10626 const char *name = ada_type_name (type);
14f9c5c9
AS
10627 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
10628
d2e4a39e
AS
10629 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
10630 {
14f9c5c9 10631 const char *tail = strstr (name, "___XF_");
5b4ee69b 10632
14f9c5c9 10633 if (tail == NULL)
4c4b4cd2 10634 return NULL;
d2e4a39e 10635 else
4c4b4cd2 10636 return tail + 5;
14f9c5c9
AS
10637 }
10638 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
10639 return fixed_type_info (TYPE_TARGET_TYPE (type));
10640 else
10641 return NULL;
10642}
10643
4c4b4cd2 10644/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
10645
10646int
ebf56fd3 10647ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
10648{
10649 return fixed_type_info (type) != NULL;
10650}
10651
4c4b4cd2
PH
10652/* Return non-zero iff TYPE represents a System.Address type. */
10653
10654int
10655ada_is_system_address_type (struct type *type)
10656{
10657 return (TYPE_NAME (type)
10658 && strcmp (TYPE_NAME (type), "system__address") == 0);
10659}
10660
14f9c5c9
AS
10661/* Assuming that TYPE is the representation of an Ada fixed-point
10662 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 10663 delta cannot be determined. */
14f9c5c9
AS
10664
10665DOUBLEST
ebf56fd3 10666ada_delta (struct type *type)
14f9c5c9
AS
10667{
10668 const char *encoding = fixed_type_info (type);
facc390f 10669 DOUBLEST num, den;
14f9c5c9 10670
facc390f
JB
10671 /* Strictly speaking, num and den are encoded as integer. However,
10672 they may not fit into a long, and they will have to be converted
10673 to DOUBLEST anyway. So scan them as DOUBLEST. */
10674 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10675 &num, &den) < 2)
14f9c5c9 10676 return -1.0;
d2e4a39e 10677 else
facc390f 10678 return num / den;
14f9c5c9
AS
10679}
10680
10681/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 10682 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
10683
10684static DOUBLEST
ebf56fd3 10685scaling_factor (struct type *type)
14f9c5c9
AS
10686{
10687 const char *encoding = fixed_type_info (type);
facc390f 10688 DOUBLEST num0, den0, num1, den1;
14f9c5c9 10689 int n;
d2e4a39e 10690
facc390f
JB
10691 /* Strictly speaking, num's and den's are encoded as integer. However,
10692 they may not fit into a long, and they will have to be converted
10693 to DOUBLEST anyway. So scan them as DOUBLEST. */
10694 n = sscanf (encoding,
10695 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
10696 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10697 &num0, &den0, &num1, &den1);
14f9c5c9
AS
10698
10699 if (n < 2)
10700 return 1.0;
10701 else if (n == 4)
facc390f 10702 return num1 / den1;
d2e4a39e 10703 else
facc390f 10704 return num0 / den0;
14f9c5c9
AS
10705}
10706
10707
10708/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 10709 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
10710
10711DOUBLEST
ebf56fd3 10712ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 10713{
d2e4a39e 10714 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
10715}
10716
4c4b4cd2
PH
10717/* The representation of a fixed-point value of type TYPE
10718 corresponding to the value X. */
14f9c5c9
AS
10719
10720LONGEST
ebf56fd3 10721ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
10722{
10723 return (LONGEST) (x / scaling_factor (type) + 0.5);
10724}
10725
14f9c5c9 10726\f
d2e4a39e 10727
4c4b4cd2 10728 /* Range types */
14f9c5c9
AS
10729
10730/* Scan STR beginning at position K for a discriminant name, and
10731 return the value of that discriminant field of DVAL in *PX. If
10732 PNEW_K is not null, put the position of the character beyond the
10733 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 10734 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
10735
10736static int
07d8f827 10737scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
76a01679 10738 int *pnew_k)
14f9c5c9
AS
10739{
10740 static char *bound_buffer = NULL;
10741 static size_t bound_buffer_len = 0;
10742 char *bound;
10743 char *pend;
d2e4a39e 10744 struct value *bound_val;
14f9c5c9
AS
10745
10746 if (dval == NULL || str == NULL || str[k] == '\0')
10747 return 0;
10748
d2e4a39e 10749 pend = strstr (str + k, "__");
14f9c5c9
AS
10750 if (pend == NULL)
10751 {
d2e4a39e 10752 bound = str + k;
14f9c5c9
AS
10753 k += strlen (bound);
10754 }
d2e4a39e 10755 else
14f9c5c9 10756 {
d2e4a39e 10757 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
14f9c5c9 10758 bound = bound_buffer;
d2e4a39e
AS
10759 strncpy (bound_buffer, str + k, pend - (str + k));
10760 bound[pend - (str + k)] = '\0';
10761 k = pend - str;
14f9c5c9 10762 }
d2e4a39e 10763
df407dfe 10764 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
10765 if (bound_val == NULL)
10766 return 0;
10767
10768 *px = value_as_long (bound_val);
10769 if (pnew_k != NULL)
10770 *pnew_k = k;
10771 return 1;
10772}
10773
10774/* Value of variable named NAME in the current environment. If
10775 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
10776 otherwise causes an error with message ERR_MSG. */
10777
d2e4a39e
AS
10778static struct value *
10779get_var_value (char *name, char *err_msg)
14f9c5c9 10780{
4c4b4cd2 10781 struct ada_symbol_info *syms;
14f9c5c9
AS
10782 int nsyms;
10783
4c4b4cd2 10784 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
4eeaa230 10785 &syms);
14f9c5c9
AS
10786
10787 if (nsyms != 1)
10788 {
10789 if (err_msg == NULL)
4c4b4cd2 10790 return 0;
14f9c5c9 10791 else
8a3fe4f8 10792 error (("%s"), err_msg);
14f9c5c9
AS
10793 }
10794
4c4b4cd2 10795 return value_of_variable (syms[0].sym, syms[0].block);
14f9c5c9 10796}
d2e4a39e 10797
14f9c5c9 10798/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
10799 no such variable found, returns 0, and sets *FLAG to 0. If
10800 successful, sets *FLAG to 1. */
10801
14f9c5c9 10802LONGEST
4c4b4cd2 10803get_int_var_value (char *name, int *flag)
14f9c5c9 10804{
4c4b4cd2 10805 struct value *var_val = get_var_value (name, 0);
d2e4a39e 10806
14f9c5c9
AS
10807 if (var_val == 0)
10808 {
10809 if (flag != NULL)
4c4b4cd2 10810 *flag = 0;
14f9c5c9
AS
10811 return 0;
10812 }
10813 else
10814 {
10815 if (flag != NULL)
4c4b4cd2 10816 *flag = 1;
14f9c5c9
AS
10817 return value_as_long (var_val);
10818 }
10819}
d2e4a39e 10820
14f9c5c9
AS
10821
10822/* Return a range type whose base type is that of the range type named
10823 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 10824 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
10825 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
10826 corresponding range type from debug information; fall back to using it
10827 if symbol lookup fails. If a new type must be created, allocate it
10828 like ORIG_TYPE was. The bounds information, in general, is encoded
10829 in NAME, the base type given in the named range type. */
14f9c5c9 10830
d2e4a39e 10831static struct type *
28c85d6c 10832to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 10833{
0d5cff50 10834 const char *name;
14f9c5c9 10835 struct type *base_type;
d2e4a39e 10836 char *subtype_info;
14f9c5c9 10837
28c85d6c
JB
10838 gdb_assert (raw_type != NULL);
10839 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 10840
1ce677a4 10841 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
10842 base_type = TYPE_TARGET_TYPE (raw_type);
10843 else
10844 base_type = raw_type;
10845
28c85d6c 10846 name = TYPE_NAME (raw_type);
14f9c5c9
AS
10847 subtype_info = strstr (name, "___XD");
10848 if (subtype_info == NULL)
690cc4eb 10849 {
43bbcdc2
PH
10850 LONGEST L = ada_discrete_type_low_bound (raw_type);
10851 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 10852
690cc4eb
PH
10853 if (L < INT_MIN || U > INT_MAX)
10854 return raw_type;
10855 else
28c85d6c 10856 return create_range_type (alloc_type_copy (raw_type), raw_type,
43bbcdc2
PH
10857 ada_discrete_type_low_bound (raw_type),
10858 ada_discrete_type_high_bound (raw_type));
690cc4eb 10859 }
14f9c5c9
AS
10860 else
10861 {
10862 static char *name_buf = NULL;
10863 static size_t name_len = 0;
10864 int prefix_len = subtype_info - name;
10865 LONGEST L, U;
10866 struct type *type;
10867 char *bounds_str;
10868 int n;
10869
10870 GROW_VECT (name_buf, name_len, prefix_len + 5);
10871 strncpy (name_buf, name, prefix_len);
10872 name_buf[prefix_len] = '\0';
10873
10874 subtype_info += 5;
10875 bounds_str = strchr (subtype_info, '_');
10876 n = 1;
10877
d2e4a39e 10878 if (*subtype_info == 'L')
4c4b4cd2
PH
10879 {
10880 if (!ada_scan_number (bounds_str, n, &L, &n)
10881 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
10882 return raw_type;
10883 if (bounds_str[n] == '_')
10884 n += 2;
0963b4bd 10885 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
10886 n += 1;
10887 subtype_info += 1;
10888 }
d2e4a39e 10889 else
4c4b4cd2
PH
10890 {
10891 int ok;
5b4ee69b 10892
4c4b4cd2
PH
10893 strcpy (name_buf + prefix_len, "___L");
10894 L = get_int_var_value (name_buf, &ok);
10895 if (!ok)
10896 {
323e0a4a 10897 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
10898 L = 1;
10899 }
10900 }
14f9c5c9 10901
d2e4a39e 10902 if (*subtype_info == 'U')
4c4b4cd2
PH
10903 {
10904 if (!ada_scan_number (bounds_str, n, &U, &n)
10905 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
10906 return raw_type;
10907 }
d2e4a39e 10908 else
4c4b4cd2
PH
10909 {
10910 int ok;
5b4ee69b 10911
4c4b4cd2
PH
10912 strcpy (name_buf + prefix_len, "___U");
10913 U = get_int_var_value (name_buf, &ok);
10914 if (!ok)
10915 {
323e0a4a 10916 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
10917 U = L;
10918 }
10919 }
14f9c5c9 10920
28c85d6c 10921 type = create_range_type (alloc_type_copy (raw_type), base_type, L, U);
d2e4a39e 10922 TYPE_NAME (type) = name;
14f9c5c9
AS
10923 return type;
10924 }
10925}
10926
4c4b4cd2
PH
10927/* True iff NAME is the name of a range type. */
10928
14f9c5c9 10929int
d2e4a39e 10930ada_is_range_type_name (const char *name)
14f9c5c9
AS
10931{
10932 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 10933}
14f9c5c9 10934\f
d2e4a39e 10935
4c4b4cd2
PH
10936 /* Modular types */
10937
10938/* True iff TYPE is an Ada modular type. */
14f9c5c9 10939
14f9c5c9 10940int
d2e4a39e 10941ada_is_modular_type (struct type *type)
14f9c5c9 10942{
18af8284 10943 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
10944
10945 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 10946 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 10947 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
10948}
10949
4c4b4cd2
PH
10950/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
10951
61ee279c 10952ULONGEST
0056e4d5 10953ada_modulus (struct type *type)
14f9c5c9 10954{
43bbcdc2 10955 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 10956}
d2e4a39e 10957\f
f7f9143b
JB
10958
10959/* Ada exception catchpoint support:
10960 ---------------------------------
10961
10962 We support 3 kinds of exception catchpoints:
10963 . catchpoints on Ada exceptions
10964 . catchpoints on unhandled Ada exceptions
10965 . catchpoints on failed assertions
10966
10967 Exceptions raised during failed assertions, or unhandled exceptions
10968 could perfectly be caught with the general catchpoint on Ada exceptions.
10969 However, we can easily differentiate these two special cases, and having
10970 the option to distinguish these two cases from the rest can be useful
10971 to zero-in on certain situations.
10972
10973 Exception catchpoints are a specialized form of breakpoint,
10974 since they rely on inserting breakpoints inside known routines
10975 of the GNAT runtime. The implementation therefore uses a standard
10976 breakpoint structure of the BP_BREAKPOINT type, but with its own set
10977 of breakpoint_ops.
10978
0259addd
JB
10979 Support in the runtime for exception catchpoints have been changed
10980 a few times already, and these changes affect the implementation
10981 of these catchpoints. In order to be able to support several
10982 variants of the runtime, we use a sniffer that will determine
28010a5d 10983 the runtime variant used by the program being debugged. */
f7f9143b 10984
3d0b0fa3
JB
10985/* Ada's standard exceptions. */
10986
10987static char *standard_exc[] = {
10988 "constraint_error",
10989 "program_error",
10990 "storage_error",
10991 "tasking_error"
10992};
10993
0259addd
JB
10994typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
10995
10996/* A structure that describes how to support exception catchpoints
10997 for a given executable. */
10998
10999struct exception_support_info
11000{
11001 /* The name of the symbol to break on in order to insert
11002 a catchpoint on exceptions. */
11003 const char *catch_exception_sym;
11004
11005 /* The name of the symbol to break on in order to insert
11006 a catchpoint on unhandled exceptions. */
11007 const char *catch_exception_unhandled_sym;
11008
11009 /* The name of the symbol to break on in order to insert
11010 a catchpoint on failed assertions. */
11011 const char *catch_assert_sym;
11012
11013 /* Assuming that the inferior just triggered an unhandled exception
11014 catchpoint, this function is responsible for returning the address
11015 in inferior memory where the name of that exception is stored.
11016 Return zero if the address could not be computed. */
11017 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11018};
11019
11020static CORE_ADDR ada_unhandled_exception_name_addr (void);
11021static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11022
11023/* The following exception support info structure describes how to
11024 implement exception catchpoints with the latest version of the
11025 Ada runtime (as of 2007-03-06). */
11026
11027static const struct exception_support_info default_exception_support_info =
11028{
11029 "__gnat_debug_raise_exception", /* catch_exception_sym */
11030 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11031 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11032 ada_unhandled_exception_name_addr
11033};
11034
11035/* The following exception support info structure describes how to
11036 implement exception catchpoints with a slightly older version
11037 of the Ada runtime. */
11038
11039static const struct exception_support_info exception_support_info_fallback =
11040{
11041 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11042 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11043 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11044 ada_unhandled_exception_name_addr_from_raise
11045};
11046
f17011e0
JB
11047/* Return nonzero if we can detect the exception support routines
11048 described in EINFO.
11049
11050 This function errors out if an abnormal situation is detected
11051 (for instance, if we find the exception support routines, but
11052 that support is found to be incomplete). */
11053
11054static int
11055ada_has_this_exception_support (const struct exception_support_info *einfo)
11056{
11057 struct symbol *sym;
11058
11059 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11060 that should be compiled with debugging information. As a result, we
11061 expect to find that symbol in the symtabs. */
11062
11063 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11064 if (sym == NULL)
a6af7abe
JB
11065 {
11066 /* Perhaps we did not find our symbol because the Ada runtime was
11067 compiled without debugging info, or simply stripped of it.
11068 It happens on some GNU/Linux distributions for instance, where
11069 users have to install a separate debug package in order to get
11070 the runtime's debugging info. In that situation, let the user
11071 know why we cannot insert an Ada exception catchpoint.
11072
11073 Note: Just for the purpose of inserting our Ada exception
11074 catchpoint, we could rely purely on the associated minimal symbol.
11075 But we would be operating in degraded mode anyway, since we are
11076 still lacking the debugging info needed later on to extract
11077 the name of the exception being raised (this name is printed in
11078 the catchpoint message, and is also used when trying to catch
11079 a specific exception). We do not handle this case for now. */
1c8e84b0
JB
11080 struct minimal_symbol *msym
11081 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11082
11083 if (msym && MSYMBOL_TYPE (msym) != mst_solib_trampoline)
a6af7abe
JB
11084 error (_("Your Ada runtime appears to be missing some debugging "
11085 "information.\nCannot insert Ada exception catchpoint "
11086 "in this configuration."));
11087
11088 return 0;
11089 }
f17011e0
JB
11090
11091 /* Make sure that the symbol we found corresponds to a function. */
11092
11093 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11094 error (_("Symbol \"%s\" is not a function (class = %d)"),
11095 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11096
11097 return 1;
11098}
11099
0259addd
JB
11100/* Inspect the Ada runtime and determine which exception info structure
11101 should be used to provide support for exception catchpoints.
11102
3eecfa55
JB
11103 This function will always set the per-inferior exception_info,
11104 or raise an error. */
0259addd
JB
11105
11106static void
11107ada_exception_support_info_sniffer (void)
11108{
3eecfa55 11109 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
11110
11111 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 11112 if (data->exception_info != NULL)
0259addd
JB
11113 return;
11114
11115 /* Check the latest (default) exception support info. */
f17011e0 11116 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 11117 {
3eecfa55 11118 data->exception_info = &default_exception_support_info;
0259addd
JB
11119 return;
11120 }
11121
11122 /* Try our fallback exception suport info. */
f17011e0 11123 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 11124 {
3eecfa55 11125 data->exception_info = &exception_support_info_fallback;
0259addd
JB
11126 return;
11127 }
11128
11129 /* Sometimes, it is normal for us to not be able to find the routine
11130 we are looking for. This happens when the program is linked with
11131 the shared version of the GNAT runtime, and the program has not been
11132 started yet. Inform the user of these two possible causes if
11133 applicable. */
11134
ccefe4c4 11135 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
11136 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11137
11138 /* If the symbol does not exist, then check that the program is
11139 already started, to make sure that shared libraries have been
11140 loaded. If it is not started, this may mean that the symbol is
11141 in a shared library. */
11142
11143 if (ptid_get_pid (inferior_ptid) == 0)
11144 error (_("Unable to insert catchpoint. Try to start the program first."));
11145
11146 /* At this point, we know that we are debugging an Ada program and
11147 that the inferior has been started, but we still are not able to
0963b4bd 11148 find the run-time symbols. That can mean that we are in
0259addd
JB
11149 configurable run time mode, or that a-except as been optimized
11150 out by the linker... In any case, at this point it is not worth
11151 supporting this feature. */
11152
7dda8cff 11153 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
11154}
11155
f7f9143b
JB
11156/* True iff FRAME is very likely to be that of a function that is
11157 part of the runtime system. This is all very heuristic, but is
11158 intended to be used as advice as to what frames are uninteresting
11159 to most users. */
11160
11161static int
11162is_known_support_routine (struct frame_info *frame)
11163{
4ed6b5be 11164 struct symtab_and_line sal;
55b87a52 11165 char *func_name;
692465f1 11166 enum language func_lang;
f7f9143b 11167 int i;
f35a17b5 11168 const char *fullname;
f7f9143b 11169
4ed6b5be
JB
11170 /* If this code does not have any debugging information (no symtab),
11171 This cannot be any user code. */
f7f9143b 11172
4ed6b5be 11173 find_frame_sal (frame, &sal);
f7f9143b
JB
11174 if (sal.symtab == NULL)
11175 return 1;
11176
4ed6b5be
JB
11177 /* If there is a symtab, but the associated source file cannot be
11178 located, then assume this is not user code: Selecting a frame
11179 for which we cannot display the code would not be very helpful
11180 for the user. This should also take care of case such as VxWorks
11181 where the kernel has some debugging info provided for a few units. */
f7f9143b 11182
f35a17b5
JK
11183 fullname = symtab_to_fullname (sal.symtab);
11184 if (access (fullname, R_OK) != 0)
f7f9143b
JB
11185 return 1;
11186
4ed6b5be
JB
11187 /* Check the unit filename againt the Ada runtime file naming.
11188 We also check the name of the objfile against the name of some
11189 known system libraries that sometimes come with debugging info
11190 too. */
11191
f7f9143b
JB
11192 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11193 {
11194 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 11195 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 11196 return 1;
4ed6b5be 11197 if (sal.symtab->objfile != NULL
4262abfb 11198 && re_exec (objfile_name (sal.symtab->objfile)))
4ed6b5be 11199 return 1;
f7f9143b
JB
11200 }
11201
4ed6b5be 11202 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 11203
e9e07ba6 11204 find_frame_funname (frame, &func_name, &func_lang, NULL);
f7f9143b
JB
11205 if (func_name == NULL)
11206 return 1;
11207
11208 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11209 {
11210 re_comp (known_auxiliary_function_name_patterns[i]);
11211 if (re_exec (func_name))
55b87a52
KS
11212 {
11213 xfree (func_name);
11214 return 1;
11215 }
f7f9143b
JB
11216 }
11217
55b87a52 11218 xfree (func_name);
f7f9143b
JB
11219 return 0;
11220}
11221
11222/* Find the first frame that contains debugging information and that is not
11223 part of the Ada run-time, starting from FI and moving upward. */
11224
0ef643c8 11225void
f7f9143b
JB
11226ada_find_printable_frame (struct frame_info *fi)
11227{
11228 for (; fi != NULL; fi = get_prev_frame (fi))
11229 {
11230 if (!is_known_support_routine (fi))
11231 {
11232 select_frame (fi);
11233 break;
11234 }
11235 }
11236
11237}
11238
11239/* Assuming that the inferior just triggered an unhandled exception
11240 catchpoint, return the address in inferior memory where the name
11241 of the exception is stored.
11242
11243 Return zero if the address could not be computed. */
11244
11245static CORE_ADDR
11246ada_unhandled_exception_name_addr (void)
0259addd
JB
11247{
11248 return parse_and_eval_address ("e.full_name");
11249}
11250
11251/* Same as ada_unhandled_exception_name_addr, except that this function
11252 should be used when the inferior uses an older version of the runtime,
11253 where the exception name needs to be extracted from a specific frame
11254 several frames up in the callstack. */
11255
11256static CORE_ADDR
11257ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
11258{
11259 int frame_level;
11260 struct frame_info *fi;
3eecfa55 11261 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
55b87a52 11262 struct cleanup *old_chain;
f7f9143b
JB
11263
11264 /* To determine the name of this exception, we need to select
11265 the frame corresponding to RAISE_SYM_NAME. This frame is
11266 at least 3 levels up, so we simply skip the first 3 frames
11267 without checking the name of their associated function. */
11268 fi = get_current_frame ();
11269 for (frame_level = 0; frame_level < 3; frame_level += 1)
11270 if (fi != NULL)
11271 fi = get_prev_frame (fi);
11272
55b87a52 11273 old_chain = make_cleanup (null_cleanup, NULL);
f7f9143b
JB
11274 while (fi != NULL)
11275 {
55b87a52 11276 char *func_name;
692465f1
JB
11277 enum language func_lang;
11278
e9e07ba6 11279 find_frame_funname (fi, &func_name, &func_lang, NULL);
55b87a52
KS
11280 if (func_name != NULL)
11281 {
11282 make_cleanup (xfree, func_name);
11283
11284 if (strcmp (func_name,
11285 data->exception_info->catch_exception_sym) == 0)
11286 break; /* We found the frame we were looking for... */
11287 fi = get_prev_frame (fi);
11288 }
f7f9143b 11289 }
55b87a52 11290 do_cleanups (old_chain);
f7f9143b
JB
11291
11292 if (fi == NULL)
11293 return 0;
11294
11295 select_frame (fi);
11296 return parse_and_eval_address ("id.full_name");
11297}
11298
11299/* Assuming the inferior just triggered an Ada exception catchpoint
11300 (of any type), return the address in inferior memory where the name
11301 of the exception is stored, if applicable.
11302
11303 Return zero if the address could not be computed, or if not relevant. */
11304
11305static CORE_ADDR
761269c8 11306ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11307 struct breakpoint *b)
11308{
3eecfa55
JB
11309 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11310
f7f9143b
JB
11311 switch (ex)
11312 {
761269c8 11313 case ada_catch_exception:
f7f9143b
JB
11314 return (parse_and_eval_address ("e.full_name"));
11315 break;
11316
761269c8 11317 case ada_catch_exception_unhandled:
3eecfa55 11318 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
11319 break;
11320
761269c8 11321 case ada_catch_assert:
f7f9143b
JB
11322 return 0; /* Exception name is not relevant in this case. */
11323 break;
11324
11325 default:
11326 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11327 break;
11328 }
11329
11330 return 0; /* Should never be reached. */
11331}
11332
11333/* Same as ada_exception_name_addr_1, except that it intercepts and contains
11334 any error that ada_exception_name_addr_1 might cause to be thrown.
11335 When an error is intercepted, a warning with the error message is printed,
11336 and zero is returned. */
11337
11338static CORE_ADDR
761269c8 11339ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11340 struct breakpoint *b)
11341{
bfd189b1 11342 volatile struct gdb_exception e;
f7f9143b
JB
11343 CORE_ADDR result = 0;
11344
11345 TRY_CATCH (e, RETURN_MASK_ERROR)
11346 {
11347 result = ada_exception_name_addr_1 (ex, b);
11348 }
11349
11350 if (e.reason < 0)
11351 {
11352 warning (_("failed to get exception name: %s"), e.message);
11353 return 0;
11354 }
11355
11356 return result;
11357}
11358
28010a5d
PA
11359static char *ada_exception_catchpoint_cond_string (const char *excep_string);
11360
11361/* Ada catchpoints.
11362
11363 In the case of catchpoints on Ada exceptions, the catchpoint will
11364 stop the target on every exception the program throws. When a user
11365 specifies the name of a specific exception, we translate this
11366 request into a condition expression (in text form), and then parse
11367 it into an expression stored in each of the catchpoint's locations.
11368 We then use this condition to check whether the exception that was
11369 raised is the one the user is interested in. If not, then the
11370 target is resumed again. We store the name of the requested
11371 exception, in order to be able to re-set the condition expression
11372 when symbols change. */
11373
11374/* An instance of this type is used to represent an Ada catchpoint
11375 breakpoint location. It includes a "struct bp_location" as a kind
11376 of base class; users downcast to "struct bp_location *" when
11377 needed. */
11378
11379struct ada_catchpoint_location
11380{
11381 /* The base class. */
11382 struct bp_location base;
11383
11384 /* The condition that checks whether the exception that was raised
11385 is the specific exception the user specified on catchpoint
11386 creation. */
11387 struct expression *excep_cond_expr;
11388};
11389
11390/* Implement the DTOR method in the bp_location_ops structure for all
11391 Ada exception catchpoint kinds. */
11392
11393static void
11394ada_catchpoint_location_dtor (struct bp_location *bl)
11395{
11396 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
11397
11398 xfree (al->excep_cond_expr);
11399}
11400
11401/* The vtable to be used in Ada catchpoint locations. */
11402
11403static const struct bp_location_ops ada_catchpoint_location_ops =
11404{
11405 ada_catchpoint_location_dtor
11406};
11407
11408/* An instance of this type is used to represent an Ada catchpoint.
11409 It includes a "struct breakpoint" as a kind of base class; users
11410 downcast to "struct breakpoint *" when needed. */
11411
11412struct ada_catchpoint
11413{
11414 /* The base class. */
11415 struct breakpoint base;
11416
11417 /* The name of the specific exception the user specified. */
11418 char *excep_string;
11419};
11420
11421/* Parse the exception condition string in the context of each of the
11422 catchpoint's locations, and store them for later evaluation. */
11423
11424static void
11425create_excep_cond_exprs (struct ada_catchpoint *c)
11426{
11427 struct cleanup *old_chain;
11428 struct bp_location *bl;
11429 char *cond_string;
11430
11431 /* Nothing to do if there's no specific exception to catch. */
11432 if (c->excep_string == NULL)
11433 return;
11434
11435 /* Same if there are no locations... */
11436 if (c->base.loc == NULL)
11437 return;
11438
11439 /* Compute the condition expression in text form, from the specific
11440 expection we want to catch. */
11441 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
11442 old_chain = make_cleanup (xfree, cond_string);
11443
11444 /* Iterate over all the catchpoint's locations, and parse an
11445 expression for each. */
11446 for (bl = c->base.loc; bl != NULL; bl = bl->next)
11447 {
11448 struct ada_catchpoint_location *ada_loc
11449 = (struct ada_catchpoint_location *) bl;
11450 struct expression *exp = NULL;
11451
11452 if (!bl->shlib_disabled)
11453 {
11454 volatile struct gdb_exception e;
bbc13ae3 11455 const char *s;
28010a5d
PA
11456
11457 s = cond_string;
11458 TRY_CATCH (e, RETURN_MASK_ERROR)
11459 {
1bb9788d
TT
11460 exp = parse_exp_1 (&s, bl->address,
11461 block_for_pc (bl->address), 0);
28010a5d
PA
11462 }
11463 if (e.reason < 0)
11464 warning (_("failed to reevaluate internal exception condition "
11465 "for catchpoint %d: %s"),
11466 c->base.number, e.message);
11467 }
11468
11469 ada_loc->excep_cond_expr = exp;
11470 }
11471
11472 do_cleanups (old_chain);
11473}
11474
11475/* Implement the DTOR method in the breakpoint_ops structure for all
11476 exception catchpoint kinds. */
11477
11478static void
761269c8 11479dtor_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
11480{
11481 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11482
11483 xfree (c->excep_string);
348d480f 11484
2060206e 11485 bkpt_breakpoint_ops.dtor (b);
28010a5d
PA
11486}
11487
11488/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11489 structure for all exception catchpoint kinds. */
11490
11491static struct bp_location *
761269c8 11492allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
11493 struct breakpoint *self)
11494{
11495 struct ada_catchpoint_location *loc;
11496
11497 loc = XNEW (struct ada_catchpoint_location);
11498 init_bp_location (&loc->base, &ada_catchpoint_location_ops, self);
11499 loc->excep_cond_expr = NULL;
11500 return &loc->base;
11501}
11502
11503/* Implement the RE_SET method in the breakpoint_ops structure for all
11504 exception catchpoint kinds. */
11505
11506static void
761269c8 11507re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
11508{
11509 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11510
11511 /* Call the base class's method. This updates the catchpoint's
11512 locations. */
2060206e 11513 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
11514
11515 /* Reparse the exception conditional expressions. One for each
11516 location. */
11517 create_excep_cond_exprs (c);
11518}
11519
11520/* Returns true if we should stop for this breakpoint hit. If the
11521 user specified a specific exception, we only want to cause a stop
11522 if the program thrown that exception. */
11523
11524static int
11525should_stop_exception (const struct bp_location *bl)
11526{
11527 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11528 const struct ada_catchpoint_location *ada_loc
11529 = (const struct ada_catchpoint_location *) bl;
11530 volatile struct gdb_exception ex;
11531 int stop;
11532
11533 /* With no specific exception, should always stop. */
11534 if (c->excep_string == NULL)
11535 return 1;
11536
11537 if (ada_loc->excep_cond_expr == NULL)
11538 {
11539 /* We will have a NULL expression if back when we were creating
11540 the expressions, this location's had failed to parse. */
11541 return 1;
11542 }
11543
11544 stop = 1;
11545 TRY_CATCH (ex, RETURN_MASK_ALL)
11546 {
11547 struct value *mark;
11548
11549 mark = value_mark ();
11550 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr));
11551 value_free_to_mark (mark);
11552 }
11553 if (ex.reason < 0)
11554 exception_fprintf (gdb_stderr, ex,
11555 _("Error in testing exception condition:\n"));
11556 return stop;
11557}
11558
11559/* Implement the CHECK_STATUS method in the breakpoint_ops structure
11560 for all exception catchpoint kinds. */
11561
11562static void
761269c8 11563check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
11564{
11565 bs->stop = should_stop_exception (bs->bp_location_at);
11566}
11567
f7f9143b
JB
11568/* Implement the PRINT_IT method in the breakpoint_ops structure
11569 for all exception catchpoint kinds. */
11570
11571static enum print_stop_action
761269c8 11572print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 11573{
79a45e25 11574 struct ui_out *uiout = current_uiout;
348d480f
PA
11575 struct breakpoint *b = bs->breakpoint_at;
11576
956a9fb9 11577 annotate_catchpoint (b->number);
f7f9143b 11578
956a9fb9 11579 if (ui_out_is_mi_like_p (uiout))
f7f9143b 11580 {
956a9fb9
JB
11581 ui_out_field_string (uiout, "reason",
11582 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11583 ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition));
f7f9143b
JB
11584 }
11585
00eb2c4a
JB
11586 ui_out_text (uiout,
11587 b->disposition == disp_del ? "\nTemporary catchpoint "
11588 : "\nCatchpoint ");
956a9fb9
JB
11589 ui_out_field_int (uiout, "bkptno", b->number);
11590 ui_out_text (uiout, ", ");
f7f9143b 11591
f7f9143b
JB
11592 switch (ex)
11593 {
761269c8
JB
11594 case ada_catch_exception:
11595 case ada_catch_exception_unhandled:
956a9fb9
JB
11596 {
11597 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
11598 char exception_name[256];
11599
11600 if (addr != 0)
11601 {
c714b426
PA
11602 read_memory (addr, (gdb_byte *) exception_name,
11603 sizeof (exception_name) - 1);
956a9fb9
JB
11604 exception_name [sizeof (exception_name) - 1] = '\0';
11605 }
11606 else
11607 {
11608 /* For some reason, we were unable to read the exception
11609 name. This could happen if the Runtime was compiled
11610 without debugging info, for instance. In that case,
11611 just replace the exception name by the generic string
11612 "exception" - it will read as "an exception" in the
11613 notification we are about to print. */
967cff16 11614 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
11615 }
11616 /* In the case of unhandled exception breakpoints, we print
11617 the exception name as "unhandled EXCEPTION_NAME", to make
11618 it clearer to the user which kind of catchpoint just got
11619 hit. We used ui_out_text to make sure that this extra
11620 info does not pollute the exception name in the MI case. */
761269c8 11621 if (ex == ada_catch_exception_unhandled)
956a9fb9
JB
11622 ui_out_text (uiout, "unhandled ");
11623 ui_out_field_string (uiout, "exception-name", exception_name);
11624 }
11625 break;
761269c8 11626 case ada_catch_assert:
956a9fb9
JB
11627 /* In this case, the name of the exception is not really
11628 important. Just print "failed assertion" to make it clearer
11629 that his program just hit an assertion-failure catchpoint.
11630 We used ui_out_text because this info does not belong in
11631 the MI output. */
11632 ui_out_text (uiout, "failed assertion");
11633 break;
f7f9143b 11634 }
956a9fb9
JB
11635 ui_out_text (uiout, " at ");
11636 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
11637
11638 return PRINT_SRC_AND_LOC;
11639}
11640
11641/* Implement the PRINT_ONE method in the breakpoint_ops structure
11642 for all exception catchpoint kinds. */
11643
11644static void
761269c8 11645print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 11646 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11647{
79a45e25 11648 struct ui_out *uiout = current_uiout;
28010a5d 11649 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
11650 struct value_print_options opts;
11651
11652 get_user_print_options (&opts);
11653 if (opts.addressprint)
f7f9143b
JB
11654 {
11655 annotate_field (4);
5af949e3 11656 ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
11657 }
11658
11659 annotate_field (5);
a6d9a66e 11660 *last_loc = b->loc;
f7f9143b
JB
11661 switch (ex)
11662 {
761269c8 11663 case ada_catch_exception:
28010a5d 11664 if (c->excep_string != NULL)
f7f9143b 11665 {
28010a5d
PA
11666 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11667
f7f9143b
JB
11668 ui_out_field_string (uiout, "what", msg);
11669 xfree (msg);
11670 }
11671 else
11672 ui_out_field_string (uiout, "what", "all Ada exceptions");
11673
11674 break;
11675
761269c8 11676 case ada_catch_exception_unhandled:
f7f9143b
JB
11677 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
11678 break;
11679
761269c8 11680 case ada_catch_assert:
f7f9143b
JB
11681 ui_out_field_string (uiout, "what", "failed Ada assertions");
11682 break;
11683
11684 default:
11685 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11686 break;
11687 }
11688}
11689
11690/* Implement the PRINT_MENTION method in the breakpoint_ops structure
11691 for all exception catchpoint kinds. */
11692
11693static void
761269c8 11694print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11695 struct breakpoint *b)
11696{
28010a5d 11697 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 11698 struct ui_out *uiout = current_uiout;
28010a5d 11699
00eb2c4a
JB
11700 ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ")
11701 : _("Catchpoint "));
11702 ui_out_field_int (uiout, "bkptno", b->number);
11703 ui_out_text (uiout, ": ");
11704
f7f9143b
JB
11705 switch (ex)
11706 {
761269c8 11707 case ada_catch_exception:
28010a5d 11708 if (c->excep_string != NULL)
00eb2c4a
JB
11709 {
11710 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11711 struct cleanup *old_chain = make_cleanup (xfree, info);
11712
11713 ui_out_text (uiout, info);
11714 do_cleanups (old_chain);
11715 }
f7f9143b 11716 else
00eb2c4a 11717 ui_out_text (uiout, _("all Ada exceptions"));
f7f9143b
JB
11718 break;
11719
761269c8 11720 case ada_catch_exception_unhandled:
00eb2c4a 11721 ui_out_text (uiout, _("unhandled Ada exceptions"));
f7f9143b
JB
11722 break;
11723
761269c8 11724 case ada_catch_assert:
00eb2c4a 11725 ui_out_text (uiout, _("failed Ada assertions"));
f7f9143b
JB
11726 break;
11727
11728 default:
11729 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11730 break;
11731 }
11732}
11733
6149aea9
PA
11734/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
11735 for all exception catchpoint kinds. */
11736
11737static void
761269c8 11738print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
11739 struct breakpoint *b, struct ui_file *fp)
11740{
28010a5d
PA
11741 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11742
6149aea9
PA
11743 switch (ex)
11744 {
761269c8 11745 case ada_catch_exception:
6149aea9 11746 fprintf_filtered (fp, "catch exception");
28010a5d
PA
11747 if (c->excep_string != NULL)
11748 fprintf_filtered (fp, " %s", c->excep_string);
6149aea9
PA
11749 break;
11750
761269c8 11751 case ada_catch_exception_unhandled:
78076abc 11752 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
11753 break;
11754
761269c8 11755 case ada_catch_assert:
6149aea9
PA
11756 fprintf_filtered (fp, "catch assert");
11757 break;
11758
11759 default:
11760 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11761 }
d9b3f62e 11762 print_recreate_thread (b, fp);
6149aea9
PA
11763}
11764
f7f9143b
JB
11765/* Virtual table for "catch exception" breakpoints. */
11766
28010a5d
PA
11767static void
11768dtor_catch_exception (struct breakpoint *b)
11769{
761269c8 11770 dtor_exception (ada_catch_exception, b);
28010a5d
PA
11771}
11772
11773static struct bp_location *
11774allocate_location_catch_exception (struct breakpoint *self)
11775{
761269c8 11776 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
11777}
11778
11779static void
11780re_set_catch_exception (struct breakpoint *b)
11781{
761269c8 11782 re_set_exception (ada_catch_exception, b);
28010a5d
PA
11783}
11784
11785static void
11786check_status_catch_exception (bpstat bs)
11787{
761269c8 11788 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
11789}
11790
f7f9143b 11791static enum print_stop_action
348d480f 11792print_it_catch_exception (bpstat bs)
f7f9143b 11793{
761269c8 11794 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
11795}
11796
11797static void
a6d9a66e 11798print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11799{
761269c8 11800 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
11801}
11802
11803static void
11804print_mention_catch_exception (struct breakpoint *b)
11805{
761269c8 11806 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
11807}
11808
6149aea9
PA
11809static void
11810print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
11811{
761269c8 11812 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
11813}
11814
2060206e 11815static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
11816
11817/* Virtual table for "catch exception unhandled" breakpoints. */
11818
28010a5d
PA
11819static void
11820dtor_catch_exception_unhandled (struct breakpoint *b)
11821{
761269c8 11822 dtor_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
11823}
11824
11825static struct bp_location *
11826allocate_location_catch_exception_unhandled (struct breakpoint *self)
11827{
761269c8 11828 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
11829}
11830
11831static void
11832re_set_catch_exception_unhandled (struct breakpoint *b)
11833{
761269c8 11834 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
11835}
11836
11837static void
11838check_status_catch_exception_unhandled (bpstat bs)
11839{
761269c8 11840 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
11841}
11842
f7f9143b 11843static enum print_stop_action
348d480f 11844print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 11845{
761269c8 11846 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
11847}
11848
11849static void
a6d9a66e
UW
11850print_one_catch_exception_unhandled (struct breakpoint *b,
11851 struct bp_location **last_loc)
f7f9143b 11852{
761269c8 11853 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
11854}
11855
11856static void
11857print_mention_catch_exception_unhandled (struct breakpoint *b)
11858{
761269c8 11859 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
11860}
11861
6149aea9
PA
11862static void
11863print_recreate_catch_exception_unhandled (struct breakpoint *b,
11864 struct ui_file *fp)
11865{
761269c8 11866 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
11867}
11868
2060206e 11869static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
11870
11871/* Virtual table for "catch assert" breakpoints. */
11872
28010a5d
PA
11873static void
11874dtor_catch_assert (struct breakpoint *b)
11875{
761269c8 11876 dtor_exception (ada_catch_assert, b);
28010a5d
PA
11877}
11878
11879static struct bp_location *
11880allocate_location_catch_assert (struct breakpoint *self)
11881{
761269c8 11882 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
11883}
11884
11885static void
11886re_set_catch_assert (struct breakpoint *b)
11887{
761269c8 11888 re_set_exception (ada_catch_assert, b);
28010a5d
PA
11889}
11890
11891static void
11892check_status_catch_assert (bpstat bs)
11893{
761269c8 11894 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
11895}
11896
f7f9143b 11897static enum print_stop_action
348d480f 11898print_it_catch_assert (bpstat bs)
f7f9143b 11899{
761269c8 11900 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
11901}
11902
11903static void
a6d9a66e 11904print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11905{
761269c8 11906 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
11907}
11908
11909static void
11910print_mention_catch_assert (struct breakpoint *b)
11911{
761269c8 11912 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
11913}
11914
6149aea9
PA
11915static void
11916print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
11917{
761269c8 11918 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
11919}
11920
2060206e 11921static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 11922
f7f9143b
JB
11923/* Return a newly allocated copy of the first space-separated token
11924 in ARGSP, and then adjust ARGSP to point immediately after that
11925 token.
11926
11927 Return NULL if ARGPS does not contain any more tokens. */
11928
11929static char *
11930ada_get_next_arg (char **argsp)
11931{
11932 char *args = *argsp;
11933 char *end;
11934 char *result;
11935
0fcd72ba 11936 args = skip_spaces (args);
f7f9143b
JB
11937 if (args[0] == '\0')
11938 return NULL; /* No more arguments. */
11939
11940 /* Find the end of the current argument. */
11941
0fcd72ba 11942 end = skip_to_space (args);
f7f9143b
JB
11943
11944 /* Adjust ARGSP to point to the start of the next argument. */
11945
11946 *argsp = end;
11947
11948 /* Make a copy of the current argument and return it. */
11949
11950 result = xmalloc (end - args + 1);
11951 strncpy (result, args, end - args);
11952 result[end - args] = '\0';
11953
11954 return result;
11955}
11956
11957/* Split the arguments specified in a "catch exception" command.
11958 Set EX to the appropriate catchpoint type.
28010a5d 11959 Set EXCEP_STRING to the name of the specific exception if
5845583d
JB
11960 specified by the user.
11961 If a condition is found at the end of the arguments, the condition
11962 expression is stored in COND_STRING (memory must be deallocated
11963 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
11964
11965static void
11966catch_ada_exception_command_split (char *args,
761269c8 11967 enum ada_exception_catchpoint_kind *ex,
5845583d
JB
11968 char **excep_string,
11969 char **cond_string)
f7f9143b
JB
11970{
11971 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
11972 char *exception_name;
5845583d 11973 char *cond = NULL;
f7f9143b
JB
11974
11975 exception_name = ada_get_next_arg (&args);
5845583d
JB
11976 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
11977 {
11978 /* This is not an exception name; this is the start of a condition
11979 expression for a catchpoint on all exceptions. So, "un-get"
11980 this token, and set exception_name to NULL. */
11981 xfree (exception_name);
11982 exception_name = NULL;
11983 args -= 2;
11984 }
f7f9143b
JB
11985 make_cleanup (xfree, exception_name);
11986
5845583d 11987 /* Check to see if we have a condition. */
f7f9143b 11988
0fcd72ba 11989 args = skip_spaces (args);
5845583d
JB
11990 if (strncmp (args, "if", 2) == 0
11991 && (isspace (args[2]) || args[2] == '\0'))
11992 {
11993 args += 2;
11994 args = skip_spaces (args);
11995
11996 if (args[0] == '\0')
11997 error (_("Condition missing after `if' keyword"));
11998 cond = xstrdup (args);
11999 make_cleanup (xfree, cond);
12000
12001 args += strlen (args);
12002 }
12003
12004 /* Check that we do not have any more arguments. Anything else
12005 is unexpected. */
f7f9143b
JB
12006
12007 if (args[0] != '\0')
12008 error (_("Junk at end of expression"));
12009
12010 discard_cleanups (old_chain);
12011
12012 if (exception_name == NULL)
12013 {
12014 /* Catch all exceptions. */
761269c8 12015 *ex = ada_catch_exception;
28010a5d 12016 *excep_string = NULL;
f7f9143b
JB
12017 }
12018 else if (strcmp (exception_name, "unhandled") == 0)
12019 {
12020 /* Catch unhandled exceptions. */
761269c8 12021 *ex = ada_catch_exception_unhandled;
28010a5d 12022 *excep_string = NULL;
f7f9143b
JB
12023 }
12024 else
12025 {
12026 /* Catch a specific exception. */
761269c8 12027 *ex = ada_catch_exception;
28010a5d 12028 *excep_string = exception_name;
f7f9143b 12029 }
5845583d 12030 *cond_string = cond;
f7f9143b
JB
12031}
12032
12033/* Return the name of the symbol on which we should break in order to
12034 implement a catchpoint of the EX kind. */
12035
12036static const char *
761269c8 12037ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 12038{
3eecfa55
JB
12039 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12040
12041 gdb_assert (data->exception_info != NULL);
0259addd 12042
f7f9143b
JB
12043 switch (ex)
12044 {
761269c8 12045 case ada_catch_exception:
3eecfa55 12046 return (data->exception_info->catch_exception_sym);
f7f9143b 12047 break;
761269c8 12048 case ada_catch_exception_unhandled:
3eecfa55 12049 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 12050 break;
761269c8 12051 case ada_catch_assert:
3eecfa55 12052 return (data->exception_info->catch_assert_sym);
f7f9143b
JB
12053 break;
12054 default:
12055 internal_error (__FILE__, __LINE__,
12056 _("unexpected catchpoint kind (%d)"), ex);
12057 }
12058}
12059
12060/* Return the breakpoint ops "virtual table" used for catchpoints
12061 of the EX kind. */
12062
c0a91b2b 12063static const struct breakpoint_ops *
761269c8 12064ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
12065{
12066 switch (ex)
12067 {
761269c8 12068 case ada_catch_exception:
f7f9143b
JB
12069 return (&catch_exception_breakpoint_ops);
12070 break;
761269c8 12071 case ada_catch_exception_unhandled:
f7f9143b
JB
12072 return (&catch_exception_unhandled_breakpoint_ops);
12073 break;
761269c8 12074 case ada_catch_assert:
f7f9143b
JB
12075 return (&catch_assert_breakpoint_ops);
12076 break;
12077 default:
12078 internal_error (__FILE__, __LINE__,
12079 _("unexpected catchpoint kind (%d)"), ex);
12080 }
12081}
12082
12083/* Return the condition that will be used to match the current exception
12084 being raised with the exception that the user wants to catch. This
12085 assumes that this condition is used when the inferior just triggered
12086 an exception catchpoint.
12087
12088 The string returned is a newly allocated string that needs to be
12089 deallocated later. */
12090
12091static char *
28010a5d 12092ada_exception_catchpoint_cond_string (const char *excep_string)
f7f9143b 12093{
3d0b0fa3
JB
12094 int i;
12095
0963b4bd 12096 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 12097 runtime units that have been compiled without debugging info; if
28010a5d 12098 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
12099 exception (e.g. "constraint_error") then, during the evaluation
12100 of the condition expression, the symbol lookup on this name would
0963b4bd 12101 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
12102 may then be set only on user-defined exceptions which have the
12103 same not-fully-qualified name (e.g. my_package.constraint_error).
12104
12105 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 12106 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
12107 exception constraint_error" is rewritten into "catch exception
12108 standard.constraint_error".
12109
12110 If an exception named contraint_error is defined in another package of
12111 the inferior program, then the only way to specify this exception as a
12112 breakpoint condition is to use its fully-qualified named:
12113 e.g. my_package.constraint_error. */
12114
12115 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12116 {
28010a5d 12117 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3
JB
12118 {
12119 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
28010a5d 12120 excep_string);
3d0b0fa3
JB
12121 }
12122 }
28010a5d 12123 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
f7f9143b
JB
12124}
12125
12126/* Return the symtab_and_line that should be used to insert an exception
12127 catchpoint of the TYPE kind.
12128
28010a5d
PA
12129 EXCEP_STRING should contain the name of a specific exception that
12130 the catchpoint should catch, or NULL otherwise.
f7f9143b 12131
28010a5d
PA
12132 ADDR_STRING returns the name of the function where the real
12133 breakpoint that implements the catchpoints is set, depending on the
12134 type of catchpoint we need to create. */
f7f9143b
JB
12135
12136static struct symtab_and_line
761269c8 12137ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
c0a91b2b 12138 char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
12139{
12140 const char *sym_name;
12141 struct symbol *sym;
f7f9143b 12142
0259addd
JB
12143 /* First, find out which exception support info to use. */
12144 ada_exception_support_info_sniffer ();
12145
12146 /* Then lookup the function on which we will break in order to catch
f7f9143b 12147 the Ada exceptions requested by the user. */
f7f9143b
JB
12148 sym_name = ada_exception_sym_name (ex);
12149 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12150
f17011e0
JB
12151 /* We can assume that SYM is not NULL at this stage. If the symbol
12152 did not exist, ada_exception_support_info_sniffer would have
12153 raised an exception.
f7f9143b 12154
f17011e0
JB
12155 Also, ada_exception_support_info_sniffer should have already
12156 verified that SYM is a function symbol. */
12157 gdb_assert (sym != NULL);
12158 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
12159
12160 /* Set ADDR_STRING. */
f7f9143b
JB
12161 *addr_string = xstrdup (sym_name);
12162
f7f9143b 12163 /* Set OPS. */
4b9eee8c 12164 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 12165
f17011e0 12166 return find_function_start_sal (sym, 1);
f7f9143b
JB
12167}
12168
b4a5b78b 12169/* Create an Ada exception catchpoint.
f7f9143b 12170
b4a5b78b 12171 EX_KIND is the kind of exception catchpoint to be created.
5845583d 12172
b4a5b78b
JB
12173 EXCEPT_STRING, if not NULL, indicates the name of the exception
12174 to which this catchpoint applies. If NULL, this catchpoint is
12175 expected to trigger for all exceptions.
f7f9143b 12176
b4a5b78b 12177 COND_STRING, if not NULL, is the catchpoint condition.
f7f9143b 12178
b4a5b78b
JB
12179 TEMPFLAG, if nonzero, means that the underlying breakpoint
12180 should be temporary.
28010a5d 12181
b4a5b78b 12182 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 12183
349774ef 12184void
28010a5d 12185create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 12186 enum ada_exception_catchpoint_kind ex_kind,
28010a5d 12187 char *excep_string,
5845583d 12188 char *cond_string,
28010a5d 12189 int tempflag,
349774ef 12190 int disabled,
28010a5d
PA
12191 int from_tty)
12192{
12193 struct ada_catchpoint *c;
b4a5b78b
JB
12194 char *addr_string = NULL;
12195 const struct breakpoint_ops *ops = NULL;
12196 struct symtab_and_line sal
12197 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
28010a5d
PA
12198
12199 c = XNEW (struct ada_catchpoint);
12200 init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string,
349774ef 12201 ops, tempflag, disabled, from_tty);
28010a5d
PA
12202 c->excep_string = excep_string;
12203 create_excep_cond_exprs (c);
5845583d
JB
12204 if (cond_string != NULL)
12205 set_breakpoint_condition (&c->base, cond_string, from_tty);
3ea46bff 12206 install_breakpoint (0, &c->base, 1);
f7f9143b
JB
12207}
12208
9ac4176b
PA
12209/* Implement the "catch exception" command. */
12210
12211static void
12212catch_ada_exception_command (char *arg, int from_tty,
12213 struct cmd_list_element *command)
12214{
12215 struct gdbarch *gdbarch = get_current_arch ();
12216 int tempflag;
761269c8 12217 enum ada_exception_catchpoint_kind ex_kind;
28010a5d 12218 char *excep_string = NULL;
5845583d 12219 char *cond_string = NULL;
9ac4176b
PA
12220
12221 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12222
12223 if (!arg)
12224 arg = "";
b4a5b78b
JB
12225 catch_ada_exception_command_split (arg, &ex_kind, &excep_string,
12226 &cond_string);
12227 create_ada_exception_catchpoint (gdbarch, ex_kind,
12228 excep_string, cond_string,
349774ef
JB
12229 tempflag, 1 /* enabled */,
12230 from_tty);
9ac4176b
PA
12231}
12232
b4a5b78b 12233/* Split the arguments specified in a "catch assert" command.
5845583d 12234
b4a5b78b
JB
12235 ARGS contains the command's arguments (or the empty string if
12236 no arguments were passed).
5845583d
JB
12237
12238 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 12239 (the memory needs to be deallocated after use). */
5845583d 12240
b4a5b78b
JB
12241static void
12242catch_ada_assert_command_split (char *args, char **cond_string)
f7f9143b 12243{
5845583d 12244 args = skip_spaces (args);
f7f9143b 12245
5845583d
JB
12246 /* Check whether a condition was provided. */
12247 if (strncmp (args, "if", 2) == 0
12248 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 12249 {
5845583d 12250 args += 2;
0fcd72ba 12251 args = skip_spaces (args);
5845583d
JB
12252 if (args[0] == '\0')
12253 error (_("condition missing after `if' keyword"));
12254 *cond_string = xstrdup (args);
f7f9143b
JB
12255 }
12256
5845583d
JB
12257 /* Otherwise, there should be no other argument at the end of
12258 the command. */
12259 else if (args[0] != '\0')
12260 error (_("Junk at end of arguments."));
f7f9143b
JB
12261}
12262
9ac4176b
PA
12263/* Implement the "catch assert" command. */
12264
12265static void
12266catch_assert_command (char *arg, int from_tty,
12267 struct cmd_list_element *command)
12268{
12269 struct gdbarch *gdbarch = get_current_arch ();
12270 int tempflag;
5845583d 12271 char *cond_string = NULL;
9ac4176b
PA
12272
12273 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12274
12275 if (!arg)
12276 arg = "";
b4a5b78b 12277 catch_ada_assert_command_split (arg, &cond_string);
761269c8 12278 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
b4a5b78b 12279 NULL, cond_string,
349774ef
JB
12280 tempflag, 1 /* enabled */,
12281 from_tty);
9ac4176b 12282}
4c4b4cd2
PH
12283 /* Operators */
12284/* Information about operators given special treatment in functions
12285 below. */
12286/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
12287
12288#define ADA_OPERATORS \
12289 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
12290 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
12291 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
12292 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
12293 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
12294 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
12295 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
12296 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
12297 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
12298 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
12299 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
12300 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
12301 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
12302 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
12303 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
12304 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
12305 OP_DEFN (OP_OTHERS, 1, 1, 0) \
12306 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
12307 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
12308
12309static void
554794dc
SDJ
12310ada_operator_length (const struct expression *exp, int pc, int *oplenp,
12311 int *argsp)
4c4b4cd2
PH
12312{
12313 switch (exp->elts[pc - 1].opcode)
12314 {
76a01679 12315 default:
4c4b4cd2
PH
12316 operator_length_standard (exp, pc, oplenp, argsp);
12317 break;
12318
12319#define OP_DEFN(op, len, args, binop) \
12320 case op: *oplenp = len; *argsp = args; break;
12321 ADA_OPERATORS;
12322#undef OP_DEFN
52ce6436
PH
12323
12324 case OP_AGGREGATE:
12325 *oplenp = 3;
12326 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
12327 break;
12328
12329 case OP_CHOICES:
12330 *oplenp = 3;
12331 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
12332 break;
4c4b4cd2
PH
12333 }
12334}
12335
c0201579
JK
12336/* Implementation of the exp_descriptor method operator_check. */
12337
12338static int
12339ada_operator_check (struct expression *exp, int pos,
12340 int (*objfile_func) (struct objfile *objfile, void *data),
12341 void *data)
12342{
12343 const union exp_element *const elts = exp->elts;
12344 struct type *type = NULL;
12345
12346 switch (elts[pos].opcode)
12347 {
12348 case UNOP_IN_RANGE:
12349 case UNOP_QUAL:
12350 type = elts[pos + 1].type;
12351 break;
12352
12353 default:
12354 return operator_check_standard (exp, pos, objfile_func, data);
12355 }
12356
12357 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
12358
12359 if (type && TYPE_OBJFILE (type)
12360 && (*objfile_func) (TYPE_OBJFILE (type), data))
12361 return 1;
12362
12363 return 0;
12364}
12365
4c4b4cd2
PH
12366static char *
12367ada_op_name (enum exp_opcode opcode)
12368{
12369 switch (opcode)
12370 {
76a01679 12371 default:
4c4b4cd2 12372 return op_name_standard (opcode);
52ce6436 12373
4c4b4cd2
PH
12374#define OP_DEFN(op, len, args, binop) case op: return #op;
12375 ADA_OPERATORS;
12376#undef OP_DEFN
52ce6436
PH
12377
12378 case OP_AGGREGATE:
12379 return "OP_AGGREGATE";
12380 case OP_CHOICES:
12381 return "OP_CHOICES";
12382 case OP_NAME:
12383 return "OP_NAME";
4c4b4cd2
PH
12384 }
12385}
12386
12387/* As for operator_length, but assumes PC is pointing at the first
12388 element of the operator, and gives meaningful results only for the
52ce6436 12389 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
12390
12391static void
76a01679
JB
12392ada_forward_operator_length (struct expression *exp, int pc,
12393 int *oplenp, int *argsp)
4c4b4cd2 12394{
76a01679 12395 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
12396 {
12397 default:
12398 *oplenp = *argsp = 0;
12399 break;
52ce6436 12400
4c4b4cd2
PH
12401#define OP_DEFN(op, len, args, binop) \
12402 case op: *oplenp = len; *argsp = args; break;
12403 ADA_OPERATORS;
12404#undef OP_DEFN
52ce6436
PH
12405
12406 case OP_AGGREGATE:
12407 *oplenp = 3;
12408 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
12409 break;
12410
12411 case OP_CHOICES:
12412 *oplenp = 3;
12413 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
12414 break;
12415
12416 case OP_STRING:
12417 case OP_NAME:
12418 {
12419 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 12420
52ce6436
PH
12421 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
12422 *argsp = 0;
12423 break;
12424 }
4c4b4cd2
PH
12425 }
12426}
12427
12428static int
12429ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
12430{
12431 enum exp_opcode op = exp->elts[elt].opcode;
12432 int oplen, nargs;
12433 int pc = elt;
12434 int i;
76a01679 12435
4c4b4cd2
PH
12436 ada_forward_operator_length (exp, elt, &oplen, &nargs);
12437
76a01679 12438 switch (op)
4c4b4cd2 12439 {
76a01679 12440 /* Ada attributes ('Foo). */
4c4b4cd2
PH
12441 case OP_ATR_FIRST:
12442 case OP_ATR_LAST:
12443 case OP_ATR_LENGTH:
12444 case OP_ATR_IMAGE:
12445 case OP_ATR_MAX:
12446 case OP_ATR_MIN:
12447 case OP_ATR_MODULUS:
12448 case OP_ATR_POS:
12449 case OP_ATR_SIZE:
12450 case OP_ATR_TAG:
12451 case OP_ATR_VAL:
12452 break;
12453
12454 case UNOP_IN_RANGE:
12455 case UNOP_QUAL:
323e0a4a
AC
12456 /* XXX: gdb_sprint_host_address, type_sprint */
12457 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
12458 gdb_print_host_address (exp->elts[pc + 1].type, stream);
12459 fprintf_filtered (stream, " (");
12460 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
12461 fprintf_filtered (stream, ")");
12462 break;
12463 case BINOP_IN_BOUNDS:
52ce6436
PH
12464 fprintf_filtered (stream, " (%d)",
12465 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
12466 break;
12467 case TERNOP_IN_RANGE:
12468 break;
12469
52ce6436
PH
12470 case OP_AGGREGATE:
12471 case OP_OTHERS:
12472 case OP_DISCRETE_RANGE:
12473 case OP_POSITIONAL:
12474 case OP_CHOICES:
12475 break;
12476
12477 case OP_NAME:
12478 case OP_STRING:
12479 {
12480 char *name = &exp->elts[elt + 2].string;
12481 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 12482
52ce6436
PH
12483 fprintf_filtered (stream, "Text: `%.*s'", len, name);
12484 break;
12485 }
12486
4c4b4cd2
PH
12487 default:
12488 return dump_subexp_body_standard (exp, stream, elt);
12489 }
12490
12491 elt += oplen;
12492 for (i = 0; i < nargs; i += 1)
12493 elt = dump_subexp (exp, stream, elt);
12494
12495 return elt;
12496}
12497
12498/* The Ada extension of print_subexp (q.v.). */
12499
76a01679
JB
12500static void
12501ada_print_subexp (struct expression *exp, int *pos,
12502 struct ui_file *stream, enum precedence prec)
4c4b4cd2 12503{
52ce6436 12504 int oplen, nargs, i;
4c4b4cd2
PH
12505 int pc = *pos;
12506 enum exp_opcode op = exp->elts[pc].opcode;
12507
12508 ada_forward_operator_length (exp, pc, &oplen, &nargs);
12509
52ce6436 12510 *pos += oplen;
4c4b4cd2
PH
12511 switch (op)
12512 {
12513 default:
52ce6436 12514 *pos -= oplen;
4c4b4cd2
PH
12515 print_subexp_standard (exp, pos, stream, prec);
12516 return;
12517
12518 case OP_VAR_VALUE:
4c4b4cd2
PH
12519 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
12520 return;
12521
12522 case BINOP_IN_BOUNDS:
323e0a4a 12523 /* XXX: sprint_subexp */
4c4b4cd2 12524 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12525 fputs_filtered (" in ", stream);
4c4b4cd2 12526 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12527 fputs_filtered ("'range", stream);
4c4b4cd2 12528 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
12529 fprintf_filtered (stream, "(%ld)",
12530 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
12531 return;
12532
12533 case TERNOP_IN_RANGE:
4c4b4cd2 12534 if (prec >= PREC_EQUAL)
76a01679 12535 fputs_filtered ("(", stream);
323e0a4a 12536 /* XXX: sprint_subexp */
4c4b4cd2 12537 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12538 fputs_filtered (" in ", stream);
4c4b4cd2
PH
12539 print_subexp (exp, pos, stream, PREC_EQUAL);
12540 fputs_filtered (" .. ", stream);
12541 print_subexp (exp, pos, stream, PREC_EQUAL);
12542 if (prec >= PREC_EQUAL)
76a01679
JB
12543 fputs_filtered (")", stream);
12544 return;
4c4b4cd2
PH
12545
12546 case OP_ATR_FIRST:
12547 case OP_ATR_LAST:
12548 case OP_ATR_LENGTH:
12549 case OP_ATR_IMAGE:
12550 case OP_ATR_MAX:
12551 case OP_ATR_MIN:
12552 case OP_ATR_MODULUS:
12553 case OP_ATR_POS:
12554 case OP_ATR_SIZE:
12555 case OP_ATR_TAG:
12556 case OP_ATR_VAL:
4c4b4cd2 12557 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
12558 {
12559 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
12560 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
12561 &type_print_raw_options);
76a01679
JB
12562 *pos += 3;
12563 }
4c4b4cd2 12564 else
76a01679 12565 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
12566 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
12567 if (nargs > 1)
76a01679
JB
12568 {
12569 int tem;
5b4ee69b 12570
76a01679
JB
12571 for (tem = 1; tem < nargs; tem += 1)
12572 {
12573 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
12574 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
12575 }
12576 fputs_filtered (")", stream);
12577 }
4c4b4cd2 12578 return;
14f9c5c9 12579
4c4b4cd2 12580 case UNOP_QUAL:
4c4b4cd2
PH
12581 type_print (exp->elts[pc + 1].type, "", stream, 0);
12582 fputs_filtered ("'(", stream);
12583 print_subexp (exp, pos, stream, PREC_PREFIX);
12584 fputs_filtered (")", stream);
12585 return;
14f9c5c9 12586
4c4b4cd2 12587 case UNOP_IN_RANGE:
323e0a4a 12588 /* XXX: sprint_subexp */
4c4b4cd2 12589 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12590 fputs_filtered (" in ", stream);
79d43c61
TT
12591 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
12592 &type_print_raw_options);
4c4b4cd2 12593 return;
52ce6436
PH
12594
12595 case OP_DISCRETE_RANGE:
12596 print_subexp (exp, pos, stream, PREC_SUFFIX);
12597 fputs_filtered ("..", stream);
12598 print_subexp (exp, pos, stream, PREC_SUFFIX);
12599 return;
12600
12601 case OP_OTHERS:
12602 fputs_filtered ("others => ", stream);
12603 print_subexp (exp, pos, stream, PREC_SUFFIX);
12604 return;
12605
12606 case OP_CHOICES:
12607 for (i = 0; i < nargs-1; i += 1)
12608 {
12609 if (i > 0)
12610 fputs_filtered ("|", stream);
12611 print_subexp (exp, pos, stream, PREC_SUFFIX);
12612 }
12613 fputs_filtered (" => ", stream);
12614 print_subexp (exp, pos, stream, PREC_SUFFIX);
12615 return;
12616
12617 case OP_POSITIONAL:
12618 print_subexp (exp, pos, stream, PREC_SUFFIX);
12619 return;
12620
12621 case OP_AGGREGATE:
12622 fputs_filtered ("(", stream);
12623 for (i = 0; i < nargs; i += 1)
12624 {
12625 if (i > 0)
12626 fputs_filtered (", ", stream);
12627 print_subexp (exp, pos, stream, PREC_SUFFIX);
12628 }
12629 fputs_filtered (")", stream);
12630 return;
4c4b4cd2
PH
12631 }
12632}
14f9c5c9
AS
12633
12634/* Table mapping opcodes into strings for printing operators
12635 and precedences of the operators. */
12636
d2e4a39e
AS
12637static const struct op_print ada_op_print_tab[] = {
12638 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
12639 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
12640 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
12641 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
12642 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
12643 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
12644 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
12645 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
12646 {"<=", BINOP_LEQ, PREC_ORDER, 0},
12647 {">=", BINOP_GEQ, PREC_ORDER, 0},
12648 {">", BINOP_GTR, PREC_ORDER, 0},
12649 {"<", BINOP_LESS, PREC_ORDER, 0},
12650 {">>", BINOP_RSH, PREC_SHIFT, 0},
12651 {"<<", BINOP_LSH, PREC_SHIFT, 0},
12652 {"+", BINOP_ADD, PREC_ADD, 0},
12653 {"-", BINOP_SUB, PREC_ADD, 0},
12654 {"&", BINOP_CONCAT, PREC_ADD, 0},
12655 {"*", BINOP_MUL, PREC_MUL, 0},
12656 {"/", BINOP_DIV, PREC_MUL, 0},
12657 {"rem", BINOP_REM, PREC_MUL, 0},
12658 {"mod", BINOP_MOD, PREC_MUL, 0},
12659 {"**", BINOP_EXP, PREC_REPEAT, 0},
12660 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
12661 {"-", UNOP_NEG, PREC_PREFIX, 0},
12662 {"+", UNOP_PLUS, PREC_PREFIX, 0},
12663 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
12664 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
12665 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
12666 {".all", UNOP_IND, PREC_SUFFIX, 1},
12667 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
12668 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
d2e4a39e 12669 {NULL, 0, 0, 0}
14f9c5c9
AS
12670};
12671\f
72d5681a
PH
12672enum ada_primitive_types {
12673 ada_primitive_type_int,
12674 ada_primitive_type_long,
12675 ada_primitive_type_short,
12676 ada_primitive_type_char,
12677 ada_primitive_type_float,
12678 ada_primitive_type_double,
12679 ada_primitive_type_void,
12680 ada_primitive_type_long_long,
12681 ada_primitive_type_long_double,
12682 ada_primitive_type_natural,
12683 ada_primitive_type_positive,
12684 ada_primitive_type_system_address,
12685 nr_ada_primitive_types
12686};
6c038f32
PH
12687
12688static void
d4a9a881 12689ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
12690 struct language_arch_info *lai)
12691{
d4a9a881 12692 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 12693
72d5681a 12694 lai->primitive_type_vector
d4a9a881 12695 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 12696 struct type *);
e9bb382b
UW
12697
12698 lai->primitive_type_vector [ada_primitive_type_int]
12699 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12700 0, "integer");
12701 lai->primitive_type_vector [ada_primitive_type_long]
12702 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
12703 0, "long_integer");
12704 lai->primitive_type_vector [ada_primitive_type_short]
12705 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
12706 0, "short_integer");
12707 lai->string_char_type
12708 = lai->primitive_type_vector [ada_primitive_type_char]
12709 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
12710 lai->primitive_type_vector [ada_primitive_type_float]
12711 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
12712 "float", NULL);
12713 lai->primitive_type_vector [ada_primitive_type_double]
12714 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
12715 "long_float", NULL);
12716 lai->primitive_type_vector [ada_primitive_type_long_long]
12717 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
12718 0, "long_long_integer");
12719 lai->primitive_type_vector [ada_primitive_type_long_double]
12720 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
12721 "long_long_float", NULL);
12722 lai->primitive_type_vector [ada_primitive_type_natural]
12723 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12724 0, "natural");
12725 lai->primitive_type_vector [ada_primitive_type_positive]
12726 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12727 0, "positive");
12728 lai->primitive_type_vector [ada_primitive_type_void]
12729 = builtin->builtin_void;
12730
12731 lai->primitive_type_vector [ada_primitive_type_system_address]
12732 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
72d5681a
PH
12733 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
12734 = "system__address";
fbb06eb1 12735
47e729a8 12736 lai->bool_type_symbol = NULL;
fbb06eb1 12737 lai->bool_type_default = builtin->builtin_bool;
6c038f32 12738}
6c038f32
PH
12739\f
12740 /* Language vector */
12741
12742/* Not really used, but needed in the ada_language_defn. */
12743
12744static void
6c7a06a3 12745emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 12746{
6c7a06a3 12747 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
12748}
12749
12750static int
12751parse (void)
12752{
12753 warnings_issued = 0;
12754 return ada_parse ();
12755}
12756
12757static const struct exp_descriptor ada_exp_descriptor = {
12758 ada_print_subexp,
12759 ada_operator_length,
c0201579 12760 ada_operator_check,
6c038f32
PH
12761 ada_op_name,
12762 ada_dump_subexp_body,
12763 ada_evaluate_subexp
12764};
12765
1a119f36 12766/* Implement the "la_get_symbol_name_cmp" language_defn method
74ccd7f5
JB
12767 for Ada. */
12768
1a119f36
JB
12769static symbol_name_cmp_ftype
12770ada_get_symbol_name_cmp (const char *lookup_name)
74ccd7f5
JB
12771{
12772 if (should_use_wild_match (lookup_name))
12773 return wild_match;
12774 else
12775 return compare_names;
12776}
12777
a5ee536b
JB
12778/* Implement the "la_read_var_value" language_defn method for Ada. */
12779
12780static struct value *
12781ada_read_var_value (struct symbol *var, struct frame_info *frame)
12782{
12783 struct block *frame_block = NULL;
12784 struct symbol *renaming_sym = NULL;
12785
12786 /* The only case where default_read_var_value is not sufficient
12787 is when VAR is a renaming... */
12788 if (frame)
12789 frame_block = get_frame_block (frame, NULL);
12790 if (frame_block)
12791 renaming_sym = ada_find_renaming_symbol (var, frame_block);
12792 if (renaming_sym != NULL)
12793 return ada_read_renaming_var_value (renaming_sym, frame_block);
12794
12795 /* This is a typical case where we expect the default_read_var_value
12796 function to work. */
12797 return default_read_var_value (var, frame);
12798}
12799
6c038f32
PH
12800const struct language_defn ada_language_defn = {
12801 "ada", /* Language name */
12802 language_ada,
6c038f32 12803 range_check_off,
6c038f32
PH
12804 case_sensitive_on, /* Yes, Ada is case-insensitive, but
12805 that's not quite what this means. */
6c038f32 12806 array_row_major,
9a044a89 12807 macro_expansion_no,
6c038f32
PH
12808 &ada_exp_descriptor,
12809 parse,
12810 ada_error,
12811 resolve,
12812 ada_printchar, /* Print a character constant */
12813 ada_printstr, /* Function to print string constant */
12814 emit_char, /* Function to print single char (not used) */
6c038f32 12815 ada_print_type, /* Print a type using appropriate syntax */
be942545 12816 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
12817 ada_val_print, /* Print a value using appropriate syntax */
12818 ada_value_print, /* Print a top-level value */
a5ee536b 12819 ada_read_var_value, /* la_read_var_value */
6c038f32 12820 NULL, /* Language specific skip_trampoline */
2b2d9e11 12821 NULL, /* name_of_this */
6c038f32
PH
12822 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
12823 basic_lookup_transparent_type, /* lookup_transparent_type */
12824 ada_la_decode, /* Language specific symbol demangler */
0963b4bd
MS
12825 NULL, /* Language specific
12826 class_name_from_physname */
6c038f32
PH
12827 ada_op_print_tab, /* expression operators for printing */
12828 0, /* c-style arrays */
12829 1, /* String lower bound */
6c038f32 12830 ada_get_gdb_completer_word_break_characters,
41d27058 12831 ada_make_symbol_completion_list,
72d5681a 12832 ada_language_arch_info,
e79af960 12833 ada_print_array_index,
41f1b697 12834 default_pass_by_reference,
ae6a3a4c 12835 c_get_string,
1a119f36 12836 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
f8eba3c6 12837 ada_iterate_over_symbols,
a53b64ea 12838 &ada_varobj_ops,
6c038f32
PH
12839 LANG_MAGIC
12840};
12841
2c0b251b
PA
12842/* Provide a prototype to silence -Wmissing-prototypes. */
12843extern initialize_file_ftype _initialize_ada_language;
12844
5bf03f13
JB
12845/* Command-list for the "set/show ada" prefix command. */
12846static struct cmd_list_element *set_ada_list;
12847static struct cmd_list_element *show_ada_list;
12848
12849/* Implement the "set ada" prefix command. */
12850
12851static void
12852set_ada_command (char *arg, int from_tty)
12853{
12854 printf_unfiltered (_(\
12855"\"set ada\" must be followed by the name of a setting.\n"));
12856 help_list (set_ada_list, "set ada ", -1, gdb_stdout);
12857}
12858
12859/* Implement the "show ada" prefix command. */
12860
12861static void
12862show_ada_command (char *args, int from_tty)
12863{
12864 cmd_show_list (show_ada_list, from_tty, "");
12865}
12866
2060206e
PA
12867static void
12868initialize_ada_catchpoint_ops (void)
12869{
12870 struct breakpoint_ops *ops;
12871
12872 initialize_breakpoint_ops ();
12873
12874 ops = &catch_exception_breakpoint_ops;
12875 *ops = bkpt_breakpoint_ops;
12876 ops->dtor = dtor_catch_exception;
12877 ops->allocate_location = allocate_location_catch_exception;
12878 ops->re_set = re_set_catch_exception;
12879 ops->check_status = check_status_catch_exception;
12880 ops->print_it = print_it_catch_exception;
12881 ops->print_one = print_one_catch_exception;
12882 ops->print_mention = print_mention_catch_exception;
12883 ops->print_recreate = print_recreate_catch_exception;
12884
12885 ops = &catch_exception_unhandled_breakpoint_ops;
12886 *ops = bkpt_breakpoint_ops;
12887 ops->dtor = dtor_catch_exception_unhandled;
12888 ops->allocate_location = allocate_location_catch_exception_unhandled;
12889 ops->re_set = re_set_catch_exception_unhandled;
12890 ops->check_status = check_status_catch_exception_unhandled;
12891 ops->print_it = print_it_catch_exception_unhandled;
12892 ops->print_one = print_one_catch_exception_unhandled;
12893 ops->print_mention = print_mention_catch_exception_unhandled;
12894 ops->print_recreate = print_recreate_catch_exception_unhandled;
12895
12896 ops = &catch_assert_breakpoint_ops;
12897 *ops = bkpt_breakpoint_ops;
12898 ops->dtor = dtor_catch_assert;
12899 ops->allocate_location = allocate_location_catch_assert;
12900 ops->re_set = re_set_catch_assert;
12901 ops->check_status = check_status_catch_assert;
12902 ops->print_it = print_it_catch_assert;
12903 ops->print_one = print_one_catch_assert;
12904 ops->print_mention = print_mention_catch_assert;
12905 ops->print_recreate = print_recreate_catch_assert;
12906}
12907
d2e4a39e 12908void
6c038f32 12909_initialize_ada_language (void)
14f9c5c9 12910{
6c038f32
PH
12911 add_language (&ada_language_defn);
12912
2060206e
PA
12913 initialize_ada_catchpoint_ops ();
12914
5bf03f13
JB
12915 add_prefix_cmd ("ada", no_class, set_ada_command,
12916 _("Prefix command for changing Ada-specfic settings"),
12917 &set_ada_list, "set ada ", 0, &setlist);
12918
12919 add_prefix_cmd ("ada", no_class, show_ada_command,
12920 _("Generic command for showing Ada-specific settings."),
12921 &show_ada_list, "show ada ", 0, &showlist);
12922
12923 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
12924 &trust_pad_over_xvs, _("\
12925Enable or disable an optimization trusting PAD types over XVS types"), _("\
12926Show whether an optimization trusting PAD types over XVS types is activated"),
12927 _("\
12928This is related to the encoding used by the GNAT compiler. The debugger\n\
12929should normally trust the contents of PAD types, but certain older versions\n\
12930of GNAT have a bug that sometimes causes the information in the PAD type\n\
12931to be incorrect. Turning this setting \"off\" allows the debugger to\n\
12932work around this bug. It is always safe to turn this option \"off\", but\n\
12933this incurs a slight performance penalty, so it is recommended to NOT change\n\
12934this option to \"off\" unless necessary."),
12935 NULL, NULL, &set_ada_list, &show_ada_list);
12936
9ac4176b
PA
12937 add_catch_command ("exception", _("\
12938Catch Ada exceptions, when raised.\n\
12939With an argument, catch only exceptions with the given name."),
12940 catch_ada_exception_command,
12941 NULL,
12942 CATCH_PERMANENT,
12943 CATCH_TEMPORARY);
12944 add_catch_command ("assert", _("\
12945Catch failed Ada assertions, when raised.\n\
12946With an argument, catch only exceptions with the given name."),
12947 catch_assert_command,
12948 NULL,
12949 CATCH_PERMANENT,
12950 CATCH_TEMPORARY);
12951
6c038f32 12952 varsize_limit = 65536;
6c038f32
PH
12953
12954 obstack_init (&symbol_list_obstack);
12955
12956 decoded_names_store = htab_create_alloc
12957 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
12958 NULL, xcalloc, xfree);
6b69afc4 12959
e802dbe0
JB
12960 /* Setup per-inferior data. */
12961 observer_attach_inferior_exit (ada_inferior_exit);
12962 ada_inferior_data
8e260fc0 12963 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
14f9c5c9 12964}