]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
daily update
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
6e681866 1/* Ada language support routines for GDB, the GNU debugger.
10a2c479 2
ecd75fc8 3 Copyright (C) 1992-2014 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>
0e9f083f 23#include <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 45#include "completer.h"
53ce3c39 46#include <sys/stat.h>
14f9c5c9 47#include "ui-out.h"
fe898f56 48#include "block.h"
04714b91 49#include "infcall.h"
de4f826b 50#include "dictionary.h"
60250e8b 51#include "exceptions.h"
f7f9143b
JB
52#include "annotate.h"
53#include "valprint.h"
9bbc9174 54#include "source.h"
0259addd 55#include "observer.h"
2ba95b9b 56#include "vec.h"
692465f1 57#include "stack.h"
fa864999 58#include "gdb_vecs.h"
79d43c61 59#include "typeprint.h"
14f9c5c9 60
ccefe4c4 61#include "psymtab.h"
40bc484c 62#include "value.h"
956a9fb9 63#include "mi/mi-common.h"
9ac4176b 64#include "arch-utils.h"
0fcd72ba 65#include "cli/cli-utils.h"
ccefe4c4 66
4c4b4cd2 67/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 68 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
69 Copied from valarith.c. */
70
71#ifndef TRUNCATION_TOWARDS_ZERO
72#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
73#endif
74
d2e4a39e 75static struct type *desc_base_type (struct type *);
14f9c5c9 76
d2e4a39e 77static struct type *desc_bounds_type (struct type *);
14f9c5c9 78
d2e4a39e 79static struct value *desc_bounds (struct value *);
14f9c5c9 80
d2e4a39e 81static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 82
d2e4a39e 83static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 84
556bdfd4 85static struct type *desc_data_target_type (struct type *);
14f9c5c9 86
d2e4a39e 87static struct value *desc_data (struct value *);
14f9c5c9 88
d2e4a39e 89static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 90
d2e4a39e 91static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 92
d2e4a39e 93static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 94
d2e4a39e 95static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 96
d2e4a39e 97static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 98
d2e4a39e 99static struct type *desc_index_type (struct type *, int);
14f9c5c9 100
d2e4a39e 101static int desc_arity (struct type *);
14f9c5c9 102
d2e4a39e 103static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 104
d2e4a39e 105static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 106
40658b94
PH
107static int full_match (const char *, const char *);
108
40bc484c 109static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 110
4c4b4cd2 111static void ada_add_block_symbols (struct obstack *,
76a01679 112 struct block *, const char *,
2570f2b7 113 domain_enum, struct objfile *, int);
14f9c5c9 114
4c4b4cd2 115static int is_nonfunction (struct ada_symbol_info *, int);
14f9c5c9 116
76a01679 117static void add_defn_to_vec (struct obstack *, struct symbol *,
2570f2b7 118 struct block *);
14f9c5c9 119
4c4b4cd2
PH
120static int num_defns_collected (struct obstack *);
121
122static struct ada_symbol_info *defns_collected (struct obstack *, int);
14f9c5c9 123
4c4b4cd2 124static struct value *resolve_subexp (struct expression **, int *, int,
76a01679 125 struct type *);
14f9c5c9 126
d2e4a39e 127static void replace_operator_with_call (struct expression **, int, int, int,
270140bd 128 struct symbol *, const struct block *);
14f9c5c9 129
d2e4a39e 130static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 131
4c4b4cd2
PH
132static char *ada_op_name (enum exp_opcode);
133
134static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 135
d2e4a39e 136static int numeric_type_p (struct type *);
14f9c5c9 137
d2e4a39e 138static int integer_type_p (struct type *);
14f9c5c9 139
d2e4a39e 140static int scalar_type_p (struct type *);
14f9c5c9 141
d2e4a39e 142static int discrete_type_p (struct type *);
14f9c5c9 143
aeb5907d
JB
144static enum ada_renaming_category parse_old_style_renaming (struct type *,
145 const char **,
146 int *,
147 const char **);
148
149static struct symbol *find_old_style_renaming_symbol (const char *,
270140bd 150 const struct block *);
aeb5907d 151
4c4b4cd2 152static struct type *ada_lookup_struct_elt_type (struct type *, char *,
76a01679 153 int, int, int *);
4c4b4cd2 154
d2e4a39e 155static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 156
b4ba55a1
JB
157static struct type *ada_find_parallel_type_with_name (struct type *,
158 const char *);
159
d2e4a39e 160static int is_dynamic_field (struct type *, int);
14f9c5c9 161
10a2c479 162static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 163 const gdb_byte *,
4c4b4cd2
PH
164 CORE_ADDR, struct value *);
165
166static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 167
28c85d6c 168static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 169
d2e4a39e 170static struct type *to_static_fixed_type (struct type *);
f192137b 171static struct type *static_unwrap_type (struct type *type);
14f9c5c9 172
d2e4a39e 173static struct value *unwrap_value (struct value *);
14f9c5c9 174
ad82864c 175static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 176
ad82864c 177static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 178
ad82864c
JB
179static long decode_packed_array_bitsize (struct type *);
180
181static struct value *decode_constrained_packed_array (struct value *);
182
183static int ada_is_packed_array_type (struct type *);
184
185static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 186
d2e4a39e 187static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 188 struct value **);
14f9c5c9 189
50810684 190static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
52ce6436 191
4c4b4cd2
PH
192static struct value *coerce_unspec_val_to_type (struct value *,
193 struct type *);
14f9c5c9 194
d2e4a39e 195static struct value *get_var_value (char *, char *);
14f9c5c9 196
d2e4a39e 197static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 198
d2e4a39e 199static int equiv_types (struct type *, struct type *);
14f9c5c9 200
d2e4a39e 201static int is_name_suffix (const char *);
14f9c5c9 202
73589123
PH
203static int advance_wild_match (const char **, const char *, int);
204
205static int wild_match (const char *, const char *);
14f9c5c9 206
d2e4a39e 207static struct value *ada_coerce_ref (struct value *);
14f9c5c9 208
4c4b4cd2
PH
209static LONGEST pos_atr (struct value *);
210
3cb382c9 211static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 212
d2e4a39e 213static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 214
4c4b4cd2
PH
215static struct symbol *standard_lookup (const char *, const struct block *,
216 domain_enum);
14f9c5c9 217
4c4b4cd2
PH
218static struct value *ada_search_struct_field (char *, struct value *, int,
219 struct type *);
220
221static struct value *ada_value_primitive_field (struct value *, int, int,
222 struct type *);
223
0d5cff50 224static int find_struct_field (const char *, struct type *, int,
52ce6436 225 struct type **, int *, int *, int *, int *);
4c4b4cd2
PH
226
227static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
228 struct value *);
229
4c4b4cd2
PH
230static int ada_resolve_function (struct ada_symbol_info *, int,
231 struct value **, int, const char *,
232 struct type *);
233
4c4b4cd2
PH
234static int ada_is_direct_array_type (struct type *);
235
72d5681a
PH
236static void ada_language_arch_info (struct gdbarch *,
237 struct language_arch_info *);
714e53ab
PH
238
239static void check_size (const struct type *);
52ce6436
PH
240
241static struct value *ada_index_struct_field (int, struct value *, int,
242 struct type *);
243
244static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
245 struct expression *,
246 int *, enum noside);
52ce6436
PH
247
248static void aggregate_assign_from_choices (struct value *, struct value *,
249 struct expression *,
250 int *, LONGEST *, int *,
251 int, LONGEST, LONGEST);
252
253static void aggregate_assign_positional (struct value *, struct value *,
254 struct expression *,
255 int *, LONGEST *, int *, int,
256 LONGEST, LONGEST);
257
258
259static void aggregate_assign_others (struct value *, struct value *,
260 struct expression *,
261 int *, LONGEST *, int, LONGEST, LONGEST);
262
263
264static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
265
266
267static struct value *ada_evaluate_subexp (struct type *, struct expression *,
268 int *, enum noside);
269
270static void ada_forward_operator_length (struct expression *, int, int *,
271 int *);
852dff6c
JB
272
273static struct type *ada_find_any_type (const char *name);
4c4b4cd2
PH
274\f
275
76a01679 276
4c4b4cd2 277/* Maximum-sized dynamic type. */
14f9c5c9
AS
278static unsigned int varsize_limit;
279
4c4b4cd2
PH
280/* FIXME: brobecker/2003-09-17: No longer a const because it is
281 returned by a function that does not return a const char *. */
282static char *ada_completer_word_break_characters =
283#ifdef VMS
284 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
285#else
14f9c5c9 286 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 287#endif
14f9c5c9 288
4c4b4cd2 289/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 290static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 291 = "__gnat_ada_main_program_name";
14f9c5c9 292
4c4b4cd2
PH
293/* Limit on the number of warnings to raise per expression evaluation. */
294static int warning_limit = 2;
295
296/* Number of warning messages issued; reset to 0 by cleanups after
297 expression evaluation. */
298static int warnings_issued = 0;
299
300static const char *known_runtime_file_name_patterns[] = {
301 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
302};
303
304static const char *known_auxiliary_function_name_patterns[] = {
305 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
306};
307
308/* Space for allocating results of ada_lookup_symbol_list. */
309static struct obstack symbol_list_obstack;
310
e802dbe0
JB
311 /* Inferior-specific data. */
312
313/* Per-inferior data for this module. */
314
315struct ada_inferior_data
316{
317 /* The ada__tags__type_specific_data type, which is used when decoding
318 tagged types. With older versions of GNAT, this type was directly
319 accessible through a component ("tsd") in the object tag. But this
320 is no longer the case, so we cache it for each inferior. */
321 struct type *tsd_type;
3eecfa55
JB
322
323 /* The exception_support_info data. This data is used to determine
324 how to implement support for Ada exception catchpoints in a given
325 inferior. */
326 const struct exception_support_info *exception_info;
e802dbe0
JB
327};
328
329/* Our key to this module's inferior data. */
330static const struct inferior_data *ada_inferior_data;
331
332/* A cleanup routine for our inferior data. */
333static void
334ada_inferior_data_cleanup (struct inferior *inf, void *arg)
335{
336 struct ada_inferior_data *data;
337
338 data = inferior_data (inf, ada_inferior_data);
339 if (data != NULL)
340 xfree (data);
341}
342
343/* Return our inferior data for the given inferior (INF).
344
345 This function always returns a valid pointer to an allocated
346 ada_inferior_data structure. If INF's inferior data has not
347 been previously set, this functions creates a new one with all
348 fields set to zero, sets INF's inferior to it, and then returns
349 a pointer to that newly allocated ada_inferior_data. */
350
351static struct ada_inferior_data *
352get_ada_inferior_data (struct inferior *inf)
353{
354 struct ada_inferior_data *data;
355
356 data = inferior_data (inf, ada_inferior_data);
357 if (data == NULL)
358 {
41bf6aca 359 data = XCNEW (struct ada_inferior_data);
e802dbe0
JB
360 set_inferior_data (inf, ada_inferior_data, data);
361 }
362
363 return data;
364}
365
366/* Perform all necessary cleanups regarding our module's inferior data
367 that is required after the inferior INF just exited. */
368
369static void
370ada_inferior_exit (struct inferior *inf)
371{
372 ada_inferior_data_cleanup (inf, NULL);
373 set_inferior_data (inf, ada_inferior_data, NULL);
374}
375
4c4b4cd2
PH
376 /* Utilities */
377
720d1a40 378/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
eed9788b 379 all typedef layers have been peeled. Otherwise, return TYPE.
720d1a40
JB
380
381 Normally, we really expect a typedef type to only have 1 typedef layer.
382 In other words, we really expect the target type of a typedef type to be
383 a non-typedef type. This is particularly true for Ada units, because
384 the language does not have a typedef vs not-typedef distinction.
385 In that respect, the Ada compiler has been trying to eliminate as many
386 typedef definitions in the debugging information, since they generally
387 do not bring any extra information (we still use typedef under certain
388 circumstances related mostly to the GNAT encoding).
389
390 Unfortunately, we have seen situations where the debugging information
391 generated by the compiler leads to such multiple typedef layers. For
392 instance, consider the following example with stabs:
393
394 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
395 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
396
397 This is an error in the debugging information which causes type
398 pck__float_array___XUP to be defined twice, and the second time,
399 it is defined as a typedef of a typedef.
400
401 This is on the fringe of legality as far as debugging information is
402 concerned, and certainly unexpected. But it is easy to handle these
403 situations correctly, so we can afford to be lenient in this case. */
404
405static struct type *
406ada_typedef_target_type (struct type *type)
407{
408 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
409 type = TYPE_TARGET_TYPE (type);
410 return type;
411}
412
41d27058
JB
413/* Given DECODED_NAME a string holding a symbol name in its
414 decoded form (ie using the Ada dotted notation), returns
415 its unqualified name. */
416
417static const char *
418ada_unqualified_name (const char *decoded_name)
419{
420 const char *result = strrchr (decoded_name, '.');
421
422 if (result != NULL)
423 result++; /* Skip the dot... */
424 else
425 result = decoded_name;
426
427 return result;
428}
429
430/* Return a string starting with '<', followed by STR, and '>'.
431 The result is good until the next call. */
432
433static char *
434add_angle_brackets (const char *str)
435{
436 static char *result = NULL;
437
438 xfree (result);
88c15c34 439 result = xstrprintf ("<%s>", str);
41d27058
JB
440 return result;
441}
96d887e8 442
4c4b4cd2
PH
443static char *
444ada_get_gdb_completer_word_break_characters (void)
445{
446 return ada_completer_word_break_characters;
447}
448
e79af960
JB
449/* Print an array element index using the Ada syntax. */
450
451static void
452ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 453 const struct value_print_options *options)
e79af960 454{
79a45b7d 455 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
456 fprintf_filtered (stream, " => ");
457}
458
f27cf670 459/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 460 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 461 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 462
f27cf670
AS
463void *
464grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 465{
d2e4a39e
AS
466 if (*size < min_size)
467 {
468 *size *= 2;
469 if (*size < min_size)
4c4b4cd2 470 *size = min_size;
f27cf670 471 vect = xrealloc (vect, *size * element_size);
d2e4a39e 472 }
f27cf670 473 return vect;
14f9c5c9
AS
474}
475
476/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 477 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
478
479static int
ebf56fd3 480field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
481{
482 int len = strlen (target);
5b4ee69b 483
d2e4a39e 484 return
4c4b4cd2
PH
485 (strncmp (field_name, target, len) == 0
486 && (field_name[len] == '\0'
487 || (strncmp (field_name + len, "___", 3) == 0
76a01679
JB
488 && strcmp (field_name + strlen (field_name) - 6,
489 "___XVN") != 0)));
14f9c5c9
AS
490}
491
492
872c8b51
JB
493/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
494 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
495 and return its index. This function also handles fields whose name
496 have ___ suffixes because the compiler sometimes alters their name
497 by adding such a suffix to represent fields with certain constraints.
498 If the field could not be found, return a negative number if
499 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
500
501int
502ada_get_field_index (const struct type *type, const char *field_name,
503 int maybe_missing)
504{
505 int fieldno;
872c8b51
JB
506 struct type *struct_type = check_typedef ((struct type *) type);
507
508 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
509 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
510 return fieldno;
511
512 if (!maybe_missing)
323e0a4a 513 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 514 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
515
516 return -1;
517}
518
519/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
520
521int
d2e4a39e 522ada_name_prefix_len (const char *name)
14f9c5c9
AS
523{
524 if (name == NULL)
525 return 0;
d2e4a39e 526 else
14f9c5c9 527 {
d2e4a39e 528 const char *p = strstr (name, "___");
5b4ee69b 529
14f9c5c9 530 if (p == NULL)
4c4b4cd2 531 return strlen (name);
14f9c5c9 532 else
4c4b4cd2 533 return p - name;
14f9c5c9
AS
534 }
535}
536
4c4b4cd2
PH
537/* Return non-zero if SUFFIX is a suffix of STR.
538 Return zero if STR is null. */
539
14f9c5c9 540static int
d2e4a39e 541is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
542{
543 int len1, len2;
5b4ee69b 544
14f9c5c9
AS
545 if (str == NULL)
546 return 0;
547 len1 = strlen (str);
548 len2 = strlen (suffix);
4c4b4cd2 549 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
550}
551
4c4b4cd2
PH
552/* The contents of value VAL, treated as a value of type TYPE. The
553 result is an lval in memory if VAL is. */
14f9c5c9 554
d2e4a39e 555static struct value *
4c4b4cd2 556coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 557{
61ee279c 558 type = ada_check_typedef (type);
df407dfe 559 if (value_type (val) == type)
4c4b4cd2 560 return val;
d2e4a39e 561 else
14f9c5c9 562 {
4c4b4cd2
PH
563 struct value *result;
564
565 /* Make sure that the object size is not unreasonable before
566 trying to allocate some memory for it. */
714e53ab 567 check_size (type);
4c4b4cd2 568
41e8491f
JK
569 if (value_lazy (val)
570 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
571 result = allocate_value_lazy (type);
572 else
573 {
574 result = allocate_value (type);
575 memcpy (value_contents_raw (result), value_contents (val),
576 TYPE_LENGTH (type));
577 }
74bcbdf3 578 set_value_component_location (result, val);
9bbda503
AC
579 set_value_bitsize (result, value_bitsize (val));
580 set_value_bitpos (result, value_bitpos (val));
42ae5230 581 set_value_address (result, value_address (val));
eca07816 582 set_value_optimized_out (result, value_optimized_out_const (val));
14f9c5c9
AS
583 return result;
584 }
585}
586
fc1a4b47
AC
587static const gdb_byte *
588cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
589{
590 if (valaddr == NULL)
591 return NULL;
592 else
593 return valaddr + offset;
594}
595
596static CORE_ADDR
ebf56fd3 597cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
598{
599 if (address == 0)
600 return 0;
d2e4a39e 601 else
14f9c5c9
AS
602 return address + offset;
603}
604
4c4b4cd2
PH
605/* Issue a warning (as for the definition of warning in utils.c, but
606 with exactly one argument rather than ...), unless the limit on the
607 number of warnings has passed during the evaluation of the current
608 expression. */
a2249542 609
77109804
AC
610/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
611 provided by "complaint". */
a0b31db1 612static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 613
14f9c5c9 614static void
a2249542 615lim_warning (const char *format, ...)
14f9c5c9 616{
a2249542 617 va_list args;
a2249542 618
5b4ee69b 619 va_start (args, format);
4c4b4cd2
PH
620 warnings_issued += 1;
621 if (warnings_issued <= warning_limit)
a2249542
MK
622 vwarning (format, args);
623
624 va_end (args);
4c4b4cd2
PH
625}
626
714e53ab
PH
627/* Issue an error if the size of an object of type T is unreasonable,
628 i.e. if it would be a bad idea to allocate a value of this type in
629 GDB. */
630
631static void
632check_size (const struct type *type)
633{
634 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 635 error (_("object size is larger than varsize-limit"));
714e53ab
PH
636}
637
0963b4bd 638/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 639static LONGEST
c3e5cd34 640max_of_size (int size)
4c4b4cd2 641{
76a01679 642 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 643
76a01679 644 return top_bit | (top_bit - 1);
4c4b4cd2
PH
645}
646
0963b4bd 647/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 648static LONGEST
c3e5cd34 649min_of_size (int size)
4c4b4cd2 650{
c3e5cd34 651 return -max_of_size (size) - 1;
4c4b4cd2
PH
652}
653
0963b4bd 654/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 655static ULONGEST
c3e5cd34 656umax_of_size (int size)
4c4b4cd2 657{
76a01679 658 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 659
76a01679 660 return top_bit | (top_bit - 1);
4c4b4cd2
PH
661}
662
0963b4bd 663/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
664static LONGEST
665max_of_type (struct type *t)
4c4b4cd2 666{
c3e5cd34
PH
667 if (TYPE_UNSIGNED (t))
668 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
669 else
670 return max_of_size (TYPE_LENGTH (t));
671}
672
0963b4bd 673/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
674static LONGEST
675min_of_type (struct type *t)
676{
677 if (TYPE_UNSIGNED (t))
678 return 0;
679 else
680 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
681}
682
683/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
684LONGEST
685ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 686{
76a01679 687 switch (TYPE_CODE (type))
4c4b4cd2
PH
688 {
689 case TYPE_CODE_RANGE:
690cc4eb 690 return TYPE_HIGH_BOUND (type);
4c4b4cd2 691 case TYPE_CODE_ENUM:
14e75d8e 692 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
693 case TYPE_CODE_BOOL:
694 return 1;
695 case TYPE_CODE_CHAR:
76a01679 696 case TYPE_CODE_INT:
690cc4eb 697 return max_of_type (type);
4c4b4cd2 698 default:
43bbcdc2 699 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
700 }
701}
702
14e75d8e 703/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
704LONGEST
705ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 706{
76a01679 707 switch (TYPE_CODE (type))
4c4b4cd2
PH
708 {
709 case TYPE_CODE_RANGE:
690cc4eb 710 return TYPE_LOW_BOUND (type);
4c4b4cd2 711 case TYPE_CODE_ENUM:
14e75d8e 712 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
713 case TYPE_CODE_BOOL:
714 return 0;
715 case TYPE_CODE_CHAR:
76a01679 716 case TYPE_CODE_INT:
690cc4eb 717 return min_of_type (type);
4c4b4cd2 718 default:
43bbcdc2 719 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
720 }
721}
722
723/* The identity on non-range types. For range types, the underlying
76a01679 724 non-range scalar type. */
4c4b4cd2
PH
725
726static struct type *
18af8284 727get_base_type (struct type *type)
4c4b4cd2
PH
728{
729 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
730 {
76a01679
JB
731 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
732 return type;
4c4b4cd2
PH
733 type = TYPE_TARGET_TYPE (type);
734 }
735 return type;
14f9c5c9 736}
41246937
JB
737
738/* Return a decoded version of the given VALUE. This means returning
739 a value whose type is obtained by applying all the GNAT-specific
740 encondings, making the resulting type a static but standard description
741 of the initial type. */
742
743struct value *
744ada_get_decoded_value (struct value *value)
745{
746 struct type *type = ada_check_typedef (value_type (value));
747
748 if (ada_is_array_descriptor_type (type)
749 || (ada_is_constrained_packed_array_type (type)
750 && TYPE_CODE (type) != TYPE_CODE_PTR))
751 {
752 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
753 value = ada_coerce_to_simple_array_ptr (value);
754 else
755 value = ada_coerce_to_simple_array (value);
756 }
757 else
758 value = ada_to_fixed_value (value);
759
760 return value;
761}
762
763/* Same as ada_get_decoded_value, but with the given TYPE.
764 Because there is no associated actual value for this type,
765 the resulting type might be a best-effort approximation in
766 the case of dynamic types. */
767
768struct type *
769ada_get_decoded_type (struct type *type)
770{
771 type = to_static_fixed_type (type);
772 if (ada_is_constrained_packed_array_type (type))
773 type = ada_coerce_to_simple_array_type (type);
774 return type;
775}
776
4c4b4cd2 777\f
76a01679 778
4c4b4cd2 779 /* Language Selection */
14f9c5c9
AS
780
781/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 782 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 783
14f9c5c9 784enum language
ccefe4c4 785ada_update_initial_language (enum language lang)
14f9c5c9 786{
d2e4a39e 787 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
4c4b4cd2
PH
788 (struct objfile *) NULL) != NULL)
789 return language_ada;
14f9c5c9
AS
790
791 return lang;
792}
96d887e8
PH
793
794/* If the main procedure is written in Ada, then return its name.
795 The result is good until the next call. Return NULL if the main
796 procedure doesn't appear to be in Ada. */
797
798char *
799ada_main_name (void)
800{
801 struct minimal_symbol *msym;
f9bc20b9 802 static char *main_program_name = NULL;
6c038f32 803
96d887e8
PH
804 /* For Ada, the name of the main procedure is stored in a specific
805 string constant, generated by the binder. Look for that symbol,
806 extract its address, and then read that string. If we didn't find
807 that string, then most probably the main procedure is not written
808 in Ada. */
809 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
810
811 if (msym != NULL)
812 {
f9bc20b9
JB
813 CORE_ADDR main_program_name_addr;
814 int err_code;
815
96d887e8
PH
816 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
817 if (main_program_name_addr == 0)
323e0a4a 818 error (_("Invalid address for Ada main program name."));
96d887e8 819
f9bc20b9
JB
820 xfree (main_program_name);
821 target_read_string (main_program_name_addr, &main_program_name,
822 1024, &err_code);
823
824 if (err_code != 0)
825 return NULL;
96d887e8
PH
826 return main_program_name;
827 }
828
829 /* The main procedure doesn't seem to be in Ada. */
830 return NULL;
831}
14f9c5c9 832\f
4c4b4cd2 833 /* Symbols */
d2e4a39e 834
4c4b4cd2
PH
835/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
836 of NULLs. */
14f9c5c9 837
d2e4a39e
AS
838const struct ada_opname_map ada_opname_table[] = {
839 {"Oadd", "\"+\"", BINOP_ADD},
840 {"Osubtract", "\"-\"", BINOP_SUB},
841 {"Omultiply", "\"*\"", BINOP_MUL},
842 {"Odivide", "\"/\"", BINOP_DIV},
843 {"Omod", "\"mod\"", BINOP_MOD},
844 {"Orem", "\"rem\"", BINOP_REM},
845 {"Oexpon", "\"**\"", BINOP_EXP},
846 {"Olt", "\"<\"", BINOP_LESS},
847 {"Ole", "\"<=\"", BINOP_LEQ},
848 {"Ogt", "\">\"", BINOP_GTR},
849 {"Oge", "\">=\"", BINOP_GEQ},
850 {"Oeq", "\"=\"", BINOP_EQUAL},
851 {"One", "\"/=\"", BINOP_NOTEQUAL},
852 {"Oand", "\"and\"", BINOP_BITWISE_AND},
853 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
854 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
855 {"Oconcat", "\"&\"", BINOP_CONCAT},
856 {"Oabs", "\"abs\"", UNOP_ABS},
857 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
858 {"Oadd", "\"+\"", UNOP_PLUS},
859 {"Osubtract", "\"-\"", UNOP_NEG},
860 {NULL, NULL}
14f9c5c9
AS
861};
862
4c4b4cd2
PH
863/* The "encoded" form of DECODED, according to GNAT conventions.
864 The result is valid until the next call to ada_encode. */
865
14f9c5c9 866char *
4c4b4cd2 867ada_encode (const char *decoded)
14f9c5c9 868{
4c4b4cd2
PH
869 static char *encoding_buffer = NULL;
870 static size_t encoding_buffer_size = 0;
d2e4a39e 871 const char *p;
14f9c5c9 872 int k;
d2e4a39e 873
4c4b4cd2 874 if (decoded == NULL)
14f9c5c9
AS
875 return NULL;
876
4c4b4cd2
PH
877 GROW_VECT (encoding_buffer, encoding_buffer_size,
878 2 * strlen (decoded) + 10);
14f9c5c9
AS
879
880 k = 0;
4c4b4cd2 881 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 882 {
cdc7bb92 883 if (*p == '.')
4c4b4cd2
PH
884 {
885 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
886 k += 2;
887 }
14f9c5c9 888 else if (*p == '"')
4c4b4cd2
PH
889 {
890 const struct ada_opname_map *mapping;
891
892 for (mapping = ada_opname_table;
1265e4aa
JB
893 mapping->encoded != NULL
894 && strncmp (mapping->decoded, p,
895 strlen (mapping->decoded)) != 0; mapping += 1)
4c4b4cd2
PH
896 ;
897 if (mapping->encoded == NULL)
323e0a4a 898 error (_("invalid Ada operator name: %s"), p);
4c4b4cd2
PH
899 strcpy (encoding_buffer + k, mapping->encoded);
900 k += strlen (mapping->encoded);
901 break;
902 }
d2e4a39e 903 else
4c4b4cd2
PH
904 {
905 encoding_buffer[k] = *p;
906 k += 1;
907 }
14f9c5c9
AS
908 }
909
4c4b4cd2
PH
910 encoding_buffer[k] = '\0';
911 return encoding_buffer;
14f9c5c9
AS
912}
913
914/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
915 quotes, unfolded, but with the quotes stripped away. Result good
916 to next call. */
917
d2e4a39e
AS
918char *
919ada_fold_name (const char *name)
14f9c5c9 920{
d2e4a39e 921 static char *fold_buffer = NULL;
14f9c5c9
AS
922 static size_t fold_buffer_size = 0;
923
924 int len = strlen (name);
d2e4a39e 925 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
926
927 if (name[0] == '\'')
928 {
d2e4a39e
AS
929 strncpy (fold_buffer, name + 1, len - 2);
930 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
931 }
932 else
933 {
934 int i;
5b4ee69b 935
14f9c5c9 936 for (i = 0; i <= len; i += 1)
4c4b4cd2 937 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
938 }
939
940 return fold_buffer;
941}
942
529cad9c
PH
943/* Return nonzero if C is either a digit or a lowercase alphabet character. */
944
945static int
946is_lower_alphanum (const char c)
947{
948 return (isdigit (c) || (isalpha (c) && islower (c)));
949}
950
c90092fe
JB
951/* ENCODED is the linkage name of a symbol and LEN contains its length.
952 This function saves in LEN the length of that same symbol name but
953 without either of these suffixes:
29480c32
JB
954 . .{DIGIT}+
955 . ${DIGIT}+
956 . ___{DIGIT}+
957 . __{DIGIT}+.
c90092fe 958
29480c32
JB
959 These are suffixes introduced by the compiler for entities such as
960 nested subprogram for instance, in order to avoid name clashes.
961 They do not serve any purpose for the debugger. */
962
963static void
964ada_remove_trailing_digits (const char *encoded, int *len)
965{
966 if (*len > 1 && isdigit (encoded[*len - 1]))
967 {
968 int i = *len - 2;
5b4ee69b 969
29480c32
JB
970 while (i > 0 && isdigit (encoded[i]))
971 i--;
972 if (i >= 0 && encoded[i] == '.')
973 *len = i;
974 else if (i >= 0 && encoded[i] == '$')
975 *len = i;
976 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
977 *len = i - 2;
978 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
979 *len = i - 1;
980 }
981}
982
983/* Remove the suffix introduced by the compiler for protected object
984 subprograms. */
985
986static void
987ada_remove_po_subprogram_suffix (const char *encoded, int *len)
988{
989 /* Remove trailing N. */
990
991 /* Protected entry subprograms are broken into two
992 separate subprograms: The first one is unprotected, and has
993 a 'N' suffix; the second is the protected version, and has
0963b4bd 994 the 'P' suffix. The second calls the first one after handling
29480c32
JB
995 the protection. Since the P subprograms are internally generated,
996 we leave these names undecoded, giving the user a clue that this
997 entity is internal. */
998
999 if (*len > 1
1000 && encoded[*len - 1] == 'N'
1001 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1002 *len = *len - 1;
1003}
1004
69fadcdf
JB
1005/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1006
1007static void
1008ada_remove_Xbn_suffix (const char *encoded, int *len)
1009{
1010 int i = *len - 1;
1011
1012 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1013 i--;
1014
1015 if (encoded[i] != 'X')
1016 return;
1017
1018 if (i == 0)
1019 return;
1020
1021 if (isalnum (encoded[i-1]))
1022 *len = i;
1023}
1024
29480c32
JB
1025/* If ENCODED follows the GNAT entity encoding conventions, then return
1026 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1027 replaced by ENCODED.
14f9c5c9 1028
4c4b4cd2 1029 The resulting string is valid until the next call of ada_decode.
29480c32 1030 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1031 is returned. */
1032
1033const char *
1034ada_decode (const char *encoded)
14f9c5c9
AS
1035{
1036 int i, j;
1037 int len0;
d2e4a39e 1038 const char *p;
4c4b4cd2 1039 char *decoded;
14f9c5c9 1040 int at_start_name;
4c4b4cd2
PH
1041 static char *decoding_buffer = NULL;
1042 static size_t decoding_buffer_size = 0;
d2e4a39e 1043
29480c32
JB
1044 /* The name of the Ada main procedure starts with "_ada_".
1045 This prefix is not part of the decoded name, so skip this part
1046 if we see this prefix. */
4c4b4cd2
PH
1047 if (strncmp (encoded, "_ada_", 5) == 0)
1048 encoded += 5;
14f9c5c9 1049
29480c32
JB
1050 /* If the name starts with '_', then it is not a properly encoded
1051 name, so do not attempt to decode it. Similarly, if the name
1052 starts with '<', the name should not be decoded. */
4c4b4cd2 1053 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1054 goto Suppress;
1055
4c4b4cd2 1056 len0 = strlen (encoded);
4c4b4cd2 1057
29480c32
JB
1058 ada_remove_trailing_digits (encoded, &len0);
1059 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1060
4c4b4cd2
PH
1061 /* Remove the ___X.* suffix if present. Do not forget to verify that
1062 the suffix is located before the current "end" of ENCODED. We want
1063 to avoid re-matching parts of ENCODED that have previously been
1064 marked as discarded (by decrementing LEN0). */
1065 p = strstr (encoded, "___");
1066 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1067 {
1068 if (p[3] == 'X')
4c4b4cd2 1069 len0 = p - encoded;
14f9c5c9 1070 else
4c4b4cd2 1071 goto Suppress;
14f9c5c9 1072 }
4c4b4cd2 1073
29480c32
JB
1074 /* Remove any trailing TKB suffix. It tells us that this symbol
1075 is for the body of a task, but that information does not actually
1076 appear in the decoded name. */
1077
4c4b4cd2 1078 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
14f9c5c9 1079 len0 -= 3;
76a01679 1080
a10967fa
JB
1081 /* Remove any trailing TB suffix. The TB suffix is slightly different
1082 from the TKB suffix because it is used for non-anonymous task
1083 bodies. */
1084
1085 if (len0 > 2 && strncmp (encoded + len0 - 2, "TB", 2) == 0)
1086 len0 -= 2;
1087
29480c32
JB
1088 /* Remove trailing "B" suffixes. */
1089 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1090
4c4b4cd2 1091 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
14f9c5c9
AS
1092 len0 -= 1;
1093
4c4b4cd2 1094 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1095
4c4b4cd2
PH
1096 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1097 decoded = decoding_buffer;
14f9c5c9 1098
29480c32
JB
1099 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1100
4c4b4cd2 1101 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1102 {
4c4b4cd2
PH
1103 i = len0 - 2;
1104 while ((i >= 0 && isdigit (encoded[i]))
1105 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1106 i -= 1;
1107 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1108 len0 = i - 1;
1109 else if (encoded[i] == '$')
1110 len0 = i;
d2e4a39e 1111 }
14f9c5c9 1112
29480c32
JB
1113 /* The first few characters that are not alphabetic are not part
1114 of any encoding we use, so we can copy them over verbatim. */
1115
4c4b4cd2
PH
1116 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1117 decoded[j] = encoded[i];
14f9c5c9
AS
1118
1119 at_start_name = 1;
1120 while (i < len0)
1121 {
29480c32 1122 /* Is this a symbol function? */
4c4b4cd2
PH
1123 if (at_start_name && encoded[i] == 'O')
1124 {
1125 int k;
5b4ee69b 1126
4c4b4cd2
PH
1127 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1128 {
1129 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1130 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1131 op_len - 1) == 0)
1132 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1133 {
1134 strcpy (decoded + j, ada_opname_table[k].decoded);
1135 at_start_name = 0;
1136 i += op_len;
1137 j += strlen (ada_opname_table[k].decoded);
1138 break;
1139 }
1140 }
1141 if (ada_opname_table[k].encoded != NULL)
1142 continue;
1143 }
14f9c5c9
AS
1144 at_start_name = 0;
1145
529cad9c
PH
1146 /* Replace "TK__" with "__", which will eventually be translated
1147 into "." (just below). */
1148
4c4b4cd2
PH
1149 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
1150 i += 2;
529cad9c 1151
29480c32
JB
1152 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1153 be translated into "." (just below). These are internal names
1154 generated for anonymous blocks inside which our symbol is nested. */
1155
1156 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1157 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1158 && isdigit (encoded [i+4]))
1159 {
1160 int k = i + 5;
1161
1162 while (k < len0 && isdigit (encoded[k]))
1163 k++; /* Skip any extra digit. */
1164
1165 /* Double-check that the "__B_{DIGITS}+" sequence we found
1166 is indeed followed by "__". */
1167 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1168 i = k;
1169 }
1170
529cad9c
PH
1171 /* Remove _E{DIGITS}+[sb] */
1172
1173 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1174 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1175 one implements the actual entry code, and has a suffix following
1176 the convention above; the second one implements the barrier and
1177 uses the same convention as above, except that the 'E' is replaced
1178 by a 'B'.
1179
1180 Just as above, we do not decode the name of barrier functions
1181 to give the user a clue that the code he is debugging has been
1182 internally generated. */
1183
1184 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1185 && isdigit (encoded[i+2]))
1186 {
1187 int k = i + 3;
1188
1189 while (k < len0 && isdigit (encoded[k]))
1190 k++;
1191
1192 if (k < len0
1193 && (encoded[k] == 'b' || encoded[k] == 's'))
1194 {
1195 k++;
1196 /* Just as an extra precaution, make sure that if this
1197 suffix is followed by anything else, it is a '_'.
1198 Otherwise, we matched this sequence by accident. */
1199 if (k == len0
1200 || (k < len0 && encoded[k] == '_'))
1201 i = k;
1202 }
1203 }
1204
1205 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1206 the GNAT front-end in protected object subprograms. */
1207
1208 if (i < len0 + 3
1209 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1210 {
1211 /* Backtrack a bit up until we reach either the begining of
1212 the encoded name, or "__". Make sure that we only find
1213 digits or lowercase characters. */
1214 const char *ptr = encoded + i - 1;
1215
1216 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1217 ptr--;
1218 if (ptr < encoded
1219 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1220 i++;
1221 }
1222
4c4b4cd2
PH
1223 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1224 {
29480c32
JB
1225 /* This is a X[bn]* sequence not separated from the previous
1226 part of the name with a non-alpha-numeric character (in other
1227 words, immediately following an alpha-numeric character), then
1228 verify that it is placed at the end of the encoded name. If
1229 not, then the encoding is not valid and we should abort the
1230 decoding. Otherwise, just skip it, it is used in body-nested
1231 package names. */
4c4b4cd2
PH
1232 do
1233 i += 1;
1234 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1235 if (i < len0)
1236 goto Suppress;
1237 }
cdc7bb92 1238 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1239 {
29480c32 1240 /* Replace '__' by '.'. */
4c4b4cd2
PH
1241 decoded[j] = '.';
1242 at_start_name = 1;
1243 i += 2;
1244 j += 1;
1245 }
14f9c5c9 1246 else
4c4b4cd2 1247 {
29480c32
JB
1248 /* It's a character part of the decoded name, so just copy it
1249 over. */
4c4b4cd2
PH
1250 decoded[j] = encoded[i];
1251 i += 1;
1252 j += 1;
1253 }
14f9c5c9 1254 }
4c4b4cd2 1255 decoded[j] = '\000';
14f9c5c9 1256
29480c32
JB
1257 /* Decoded names should never contain any uppercase character.
1258 Double-check this, and abort the decoding if we find one. */
1259
4c4b4cd2
PH
1260 for (i = 0; decoded[i] != '\0'; i += 1)
1261 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1262 goto Suppress;
1263
4c4b4cd2
PH
1264 if (strcmp (decoded, encoded) == 0)
1265 return encoded;
1266 else
1267 return decoded;
14f9c5c9
AS
1268
1269Suppress:
4c4b4cd2
PH
1270 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1271 decoded = decoding_buffer;
1272 if (encoded[0] == '<')
1273 strcpy (decoded, encoded);
14f9c5c9 1274 else
88c15c34 1275 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1276 return decoded;
1277
1278}
1279
1280/* Table for keeping permanent unique copies of decoded names. Once
1281 allocated, names in this table are never released. While this is a
1282 storage leak, it should not be significant unless there are massive
1283 changes in the set of decoded names in successive versions of a
1284 symbol table loaded during a single session. */
1285static struct htab *decoded_names_store;
1286
1287/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1288 in the language-specific part of GSYMBOL, if it has not been
1289 previously computed. Tries to save the decoded name in the same
1290 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1291 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1292 GSYMBOL).
4c4b4cd2
PH
1293 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1294 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1295 when a decoded name is cached in it. */
4c4b4cd2 1296
45e6c716 1297const char *
f85f34ed 1298ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1299{
f85f34ed
TT
1300 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1301 const char **resultp =
1302 &gsymbol->language_specific.mangled_lang.demangled_name;
5b4ee69b 1303
f85f34ed 1304 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1305 {
1306 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1307 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1308
f85f34ed 1309 gsymbol->ada_mangled = 1;
5b4ee69b 1310
f85f34ed
TT
1311 if (obstack != NULL)
1312 *resultp = obstack_copy0 (obstack, decoded, strlen (decoded));
1313 else
76a01679 1314 {
f85f34ed
TT
1315 /* Sometimes, we can't find a corresponding objfile, in
1316 which case, we put the result on the heap. Since we only
1317 decode when needed, we hope this usually does not cause a
1318 significant memory leak (FIXME). */
1319
76a01679
JB
1320 char **slot = (char **) htab_find_slot (decoded_names_store,
1321 decoded, INSERT);
5b4ee69b 1322
76a01679
JB
1323 if (*slot == NULL)
1324 *slot = xstrdup (decoded);
1325 *resultp = *slot;
1326 }
4c4b4cd2 1327 }
14f9c5c9 1328
4c4b4cd2
PH
1329 return *resultp;
1330}
76a01679 1331
2c0b251b 1332static char *
76a01679 1333ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1334{
1335 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1336}
1337
1338/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
4c4b4cd2
PH
1339 suffixes that encode debugging information or leading _ada_ on
1340 SYM_NAME (see is_name_suffix commentary for the debugging
1341 information that is ignored). If WILD, then NAME need only match a
1342 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1343 either argument is NULL. */
14f9c5c9 1344
2c0b251b 1345static int
40658b94 1346match_name (const char *sym_name, const char *name, int wild)
14f9c5c9
AS
1347{
1348 if (sym_name == NULL || name == NULL)
1349 return 0;
1350 else if (wild)
73589123 1351 return wild_match (sym_name, name) == 0;
d2e4a39e
AS
1352 else
1353 {
1354 int len_name = strlen (name);
5b4ee69b 1355
4c4b4cd2
PH
1356 return (strncmp (sym_name, name, len_name) == 0
1357 && is_name_suffix (sym_name + len_name))
1358 || (strncmp (sym_name, "_ada_", 5) == 0
1359 && strncmp (sym_name + 5, name, len_name) == 0
1360 && is_name_suffix (sym_name + len_name + 5));
d2e4a39e 1361 }
14f9c5c9 1362}
14f9c5c9 1363\f
d2e4a39e 1364
4c4b4cd2 1365 /* Arrays */
14f9c5c9 1366
28c85d6c
JB
1367/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1368 generated by the GNAT compiler to describe the index type used
1369 for each dimension of an array, check whether it follows the latest
1370 known encoding. If not, fix it up to conform to the latest encoding.
1371 Otherwise, do nothing. This function also does nothing if
1372 INDEX_DESC_TYPE is NULL.
1373
1374 The GNAT encoding used to describle the array index type evolved a bit.
1375 Initially, the information would be provided through the name of each
1376 field of the structure type only, while the type of these fields was
1377 described as unspecified and irrelevant. The debugger was then expected
1378 to perform a global type lookup using the name of that field in order
1379 to get access to the full index type description. Because these global
1380 lookups can be very expensive, the encoding was later enhanced to make
1381 the global lookup unnecessary by defining the field type as being
1382 the full index type description.
1383
1384 The purpose of this routine is to allow us to support older versions
1385 of the compiler by detecting the use of the older encoding, and by
1386 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1387 we essentially replace each field's meaningless type by the associated
1388 index subtype). */
1389
1390void
1391ada_fixup_array_indexes_type (struct type *index_desc_type)
1392{
1393 int i;
1394
1395 if (index_desc_type == NULL)
1396 return;
1397 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1398
1399 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1400 to check one field only, no need to check them all). If not, return
1401 now.
1402
1403 If our INDEX_DESC_TYPE was generated using the older encoding,
1404 the field type should be a meaningless integer type whose name
1405 is not equal to the field name. */
1406 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1407 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1408 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1409 return;
1410
1411 /* Fixup each field of INDEX_DESC_TYPE. */
1412 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1413 {
0d5cff50 1414 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1415 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1416
1417 if (raw_type)
1418 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1419 }
1420}
1421
4c4b4cd2 1422/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1423
d2e4a39e
AS
1424static char *bound_name[] = {
1425 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1426 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1427};
1428
1429/* Maximum number of array dimensions we are prepared to handle. */
1430
4c4b4cd2 1431#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1432
14f9c5c9 1433
4c4b4cd2
PH
1434/* The desc_* routines return primitive portions of array descriptors
1435 (fat pointers). */
14f9c5c9
AS
1436
1437/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1438 level of indirection, if needed. */
1439
d2e4a39e
AS
1440static struct type *
1441desc_base_type (struct type *type)
14f9c5c9
AS
1442{
1443 if (type == NULL)
1444 return NULL;
61ee279c 1445 type = ada_check_typedef (type);
720d1a40
JB
1446 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1447 type = ada_typedef_target_type (type);
1448
1265e4aa
JB
1449 if (type != NULL
1450 && (TYPE_CODE (type) == TYPE_CODE_PTR
1451 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1452 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1453 else
1454 return type;
1455}
1456
4c4b4cd2
PH
1457/* True iff TYPE indicates a "thin" array pointer type. */
1458
14f9c5c9 1459static int
d2e4a39e 1460is_thin_pntr (struct type *type)
14f9c5c9 1461{
d2e4a39e 1462 return
14f9c5c9
AS
1463 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1464 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1465}
1466
4c4b4cd2
PH
1467/* The descriptor type for thin pointer type TYPE. */
1468
d2e4a39e
AS
1469static struct type *
1470thin_descriptor_type (struct type *type)
14f9c5c9 1471{
d2e4a39e 1472 struct type *base_type = desc_base_type (type);
5b4ee69b 1473
14f9c5c9
AS
1474 if (base_type == NULL)
1475 return NULL;
1476 if (is_suffix (ada_type_name (base_type), "___XVE"))
1477 return base_type;
d2e4a39e 1478 else
14f9c5c9 1479 {
d2e4a39e 1480 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1481
14f9c5c9 1482 if (alt_type == NULL)
4c4b4cd2 1483 return base_type;
14f9c5c9 1484 else
4c4b4cd2 1485 return alt_type;
14f9c5c9
AS
1486 }
1487}
1488
4c4b4cd2
PH
1489/* A pointer to the array data for thin-pointer value VAL. */
1490
d2e4a39e
AS
1491static struct value *
1492thin_data_pntr (struct value *val)
14f9c5c9 1493{
828292f2 1494 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1495 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1496
556bdfd4
UW
1497 data_type = lookup_pointer_type (data_type);
1498
14f9c5c9 1499 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1500 return value_cast (data_type, value_copy (val));
d2e4a39e 1501 else
42ae5230 1502 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1503}
1504
4c4b4cd2
PH
1505/* True iff TYPE indicates a "thick" array pointer type. */
1506
14f9c5c9 1507static int
d2e4a39e 1508is_thick_pntr (struct type *type)
14f9c5c9
AS
1509{
1510 type = desc_base_type (type);
1511 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1512 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1513}
1514
4c4b4cd2
PH
1515/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1516 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1517
d2e4a39e
AS
1518static struct type *
1519desc_bounds_type (struct type *type)
14f9c5c9 1520{
d2e4a39e 1521 struct type *r;
14f9c5c9
AS
1522
1523 type = desc_base_type (type);
1524
1525 if (type == NULL)
1526 return NULL;
1527 else if (is_thin_pntr (type))
1528 {
1529 type = thin_descriptor_type (type);
1530 if (type == NULL)
4c4b4cd2 1531 return NULL;
14f9c5c9
AS
1532 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1533 if (r != NULL)
61ee279c 1534 return ada_check_typedef (r);
14f9c5c9
AS
1535 }
1536 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1537 {
1538 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1539 if (r != NULL)
61ee279c 1540 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1541 }
1542 return NULL;
1543}
1544
1545/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1546 one, a pointer to its bounds data. Otherwise NULL. */
1547
d2e4a39e
AS
1548static struct value *
1549desc_bounds (struct value *arr)
14f9c5c9 1550{
df407dfe 1551 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1552
d2e4a39e 1553 if (is_thin_pntr (type))
14f9c5c9 1554 {
d2e4a39e 1555 struct type *bounds_type =
4c4b4cd2 1556 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1557 LONGEST addr;
1558
4cdfadb1 1559 if (bounds_type == NULL)
323e0a4a 1560 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1561
1562 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1563 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1564 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1565 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1566 addr = value_as_long (arr);
d2e4a39e 1567 else
42ae5230 1568 addr = value_address (arr);
14f9c5c9 1569
d2e4a39e 1570 return
4c4b4cd2
PH
1571 value_from_longest (lookup_pointer_type (bounds_type),
1572 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1573 }
1574
1575 else if (is_thick_pntr (type))
05e522ef
JB
1576 {
1577 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1578 _("Bad GNAT array descriptor"));
1579 struct type *p_bounds_type = value_type (p_bounds);
1580
1581 if (p_bounds_type
1582 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1583 {
1584 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1585
1586 if (TYPE_STUB (target_type))
1587 p_bounds = value_cast (lookup_pointer_type
1588 (ada_check_typedef (target_type)),
1589 p_bounds);
1590 }
1591 else
1592 error (_("Bad GNAT array descriptor"));
1593
1594 return p_bounds;
1595 }
14f9c5c9
AS
1596 else
1597 return NULL;
1598}
1599
4c4b4cd2
PH
1600/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1601 position of the field containing the address of the bounds data. */
1602
14f9c5c9 1603static int
d2e4a39e 1604fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1605{
1606 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1607}
1608
1609/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1610 size of the field containing the address of the bounds data. */
1611
14f9c5c9 1612static int
d2e4a39e 1613fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1614{
1615 type = desc_base_type (type);
1616
d2e4a39e 1617 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1618 return TYPE_FIELD_BITSIZE (type, 1);
1619 else
61ee279c 1620 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1621}
1622
4c4b4cd2 1623/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1624 pointer to one, the type of its array data (a array-with-no-bounds type);
1625 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1626 data. */
4c4b4cd2 1627
d2e4a39e 1628static struct type *
556bdfd4 1629desc_data_target_type (struct type *type)
14f9c5c9
AS
1630{
1631 type = desc_base_type (type);
1632
4c4b4cd2 1633 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1634 if (is_thin_pntr (type))
556bdfd4 1635 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1636 else if (is_thick_pntr (type))
556bdfd4
UW
1637 {
1638 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1639
1640 if (data_type
1641 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1642 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1643 }
1644
1645 return NULL;
14f9c5c9
AS
1646}
1647
1648/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1649 its array data. */
4c4b4cd2 1650
d2e4a39e
AS
1651static struct value *
1652desc_data (struct value *arr)
14f9c5c9 1653{
df407dfe 1654 struct type *type = value_type (arr);
5b4ee69b 1655
14f9c5c9
AS
1656 if (is_thin_pntr (type))
1657 return thin_data_pntr (arr);
1658 else if (is_thick_pntr (type))
d2e4a39e 1659 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1660 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1661 else
1662 return NULL;
1663}
1664
1665
1666/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1667 position of the field containing the address of the data. */
1668
14f9c5c9 1669static int
d2e4a39e 1670fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1671{
1672 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1673}
1674
1675/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1676 size of the field containing the address of the data. */
1677
14f9c5c9 1678static int
d2e4a39e 1679fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1680{
1681 type = desc_base_type (type);
1682
1683 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1684 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1685 else
14f9c5c9
AS
1686 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1687}
1688
4c4b4cd2 1689/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1690 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1691 bound, if WHICH is 1. The first bound is I=1. */
1692
d2e4a39e
AS
1693static struct value *
1694desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1695{
d2e4a39e 1696 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1697 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1698}
1699
1700/* If BOUNDS is an array-bounds structure type, return the bit position
1701 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1702 bound, if WHICH is 1. The first bound is I=1. */
1703
14f9c5c9 1704static int
d2e4a39e 1705desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1706{
d2e4a39e 1707 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1708}
1709
1710/* If BOUNDS is an array-bounds structure type, return the bit field size
1711 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1712 bound, if WHICH is 1. The first bound is I=1. */
1713
76a01679 1714static int
d2e4a39e 1715desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1716{
1717 type = desc_base_type (type);
1718
d2e4a39e
AS
1719 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1720 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1721 else
1722 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1723}
1724
1725/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1726 Ith bound (numbering from 1). Otherwise, NULL. */
1727
d2e4a39e
AS
1728static struct type *
1729desc_index_type (struct type *type, int i)
14f9c5c9
AS
1730{
1731 type = desc_base_type (type);
1732
1733 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1734 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1735 else
14f9c5c9
AS
1736 return NULL;
1737}
1738
4c4b4cd2
PH
1739/* The number of index positions in the array-bounds type TYPE.
1740 Return 0 if TYPE is NULL. */
1741
14f9c5c9 1742static int
d2e4a39e 1743desc_arity (struct type *type)
14f9c5c9
AS
1744{
1745 type = desc_base_type (type);
1746
1747 if (type != NULL)
1748 return TYPE_NFIELDS (type) / 2;
1749 return 0;
1750}
1751
4c4b4cd2
PH
1752/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1753 an array descriptor type (representing an unconstrained array
1754 type). */
1755
76a01679
JB
1756static int
1757ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1758{
1759 if (type == NULL)
1760 return 0;
61ee279c 1761 type = ada_check_typedef (type);
4c4b4cd2 1762 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1763 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1764}
1765
52ce6436 1766/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1767 * to one. */
52ce6436 1768
2c0b251b 1769static int
52ce6436
PH
1770ada_is_array_type (struct type *type)
1771{
1772 while (type != NULL
1773 && (TYPE_CODE (type) == TYPE_CODE_PTR
1774 || TYPE_CODE (type) == TYPE_CODE_REF))
1775 type = TYPE_TARGET_TYPE (type);
1776 return ada_is_direct_array_type (type);
1777}
1778
4c4b4cd2 1779/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1780
14f9c5c9 1781int
4c4b4cd2 1782ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1783{
1784 if (type == NULL)
1785 return 0;
61ee279c 1786 type = ada_check_typedef (type);
14f9c5c9 1787 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1788 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1789 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1790 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1791}
1792
4c4b4cd2
PH
1793/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1794
14f9c5c9 1795int
4c4b4cd2 1796ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1797{
556bdfd4 1798 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1799
1800 if (type == NULL)
1801 return 0;
61ee279c 1802 type = ada_check_typedef (type);
556bdfd4
UW
1803 return (data_type != NULL
1804 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1805 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1806}
1807
1808/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1809 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1810 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1811 is still needed. */
1812
14f9c5c9 1813int
ebf56fd3 1814ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1815{
d2e4a39e 1816 return
14f9c5c9
AS
1817 type != NULL
1818 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1819 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1820 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1821 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1822}
1823
1824
4c4b4cd2 1825/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1826 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1827 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1828 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1829 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1830 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1831 a descriptor. */
d2e4a39e
AS
1832struct type *
1833ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1834{
ad82864c
JB
1835 if (ada_is_constrained_packed_array_type (value_type (arr)))
1836 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1837
df407dfe
AC
1838 if (!ada_is_array_descriptor_type (value_type (arr)))
1839 return value_type (arr);
d2e4a39e
AS
1840
1841 if (!bounds)
ad82864c
JB
1842 {
1843 struct type *array_type =
1844 ada_check_typedef (desc_data_target_type (value_type (arr)));
1845
1846 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1847 TYPE_FIELD_BITSIZE (array_type, 0) =
1848 decode_packed_array_bitsize (value_type (arr));
1849
1850 return array_type;
1851 }
14f9c5c9
AS
1852 else
1853 {
d2e4a39e 1854 struct type *elt_type;
14f9c5c9 1855 int arity;
d2e4a39e 1856 struct value *descriptor;
14f9c5c9 1857
df407dfe
AC
1858 elt_type = ada_array_element_type (value_type (arr), -1);
1859 arity = ada_array_arity (value_type (arr));
14f9c5c9 1860
d2e4a39e 1861 if (elt_type == NULL || arity == 0)
df407dfe 1862 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
1863
1864 descriptor = desc_bounds (arr);
d2e4a39e 1865 if (value_as_long (descriptor) == 0)
4c4b4cd2 1866 return NULL;
d2e4a39e 1867 while (arity > 0)
4c4b4cd2 1868 {
e9bb382b
UW
1869 struct type *range_type = alloc_type_copy (value_type (arr));
1870 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
1871 struct value *low = desc_one_bound (descriptor, arity, 0);
1872 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 1873
5b4ee69b 1874 arity -= 1;
df407dfe 1875 create_range_type (range_type, value_type (low),
529cad9c
PH
1876 longest_to_int (value_as_long (low)),
1877 longest_to_int (value_as_long (high)));
4c4b4cd2 1878 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
1879
1880 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
1881 {
1882 /* We need to store the element packed bitsize, as well as
1883 recompute the array size, because it was previously
1884 computed based on the unpacked element size. */
1885 LONGEST lo = value_as_long (low);
1886 LONGEST hi = value_as_long (high);
1887
1888 TYPE_FIELD_BITSIZE (elt_type, 0) =
1889 decode_packed_array_bitsize (value_type (arr));
1890 /* If the array has no element, then the size is already
1891 zero, and does not need to be recomputed. */
1892 if (lo < hi)
1893 {
1894 int array_bitsize =
1895 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1896
1897 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
1898 }
1899 }
4c4b4cd2 1900 }
14f9c5c9
AS
1901
1902 return lookup_pointer_type (elt_type);
1903 }
1904}
1905
1906/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
1907 Otherwise, returns either a standard GDB array with bounds set
1908 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1909 GDB array. Returns NULL if ARR is a null fat pointer. */
1910
d2e4a39e
AS
1911struct value *
1912ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 1913{
df407dfe 1914 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 1915 {
d2e4a39e 1916 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 1917
14f9c5c9 1918 if (arrType == NULL)
4c4b4cd2 1919 return NULL;
14f9c5c9
AS
1920 return value_cast (arrType, value_copy (desc_data (arr)));
1921 }
ad82864c
JB
1922 else if (ada_is_constrained_packed_array_type (value_type (arr)))
1923 return decode_constrained_packed_array (arr);
14f9c5c9
AS
1924 else
1925 return arr;
1926}
1927
1928/* If ARR does not represent an array, returns ARR unchanged.
1929 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
1930 be ARR itself if it already is in the proper form). */
1931
720d1a40 1932struct value *
d2e4a39e 1933ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 1934{
df407dfe 1935 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 1936 {
d2e4a39e 1937 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 1938
14f9c5c9 1939 if (arrVal == NULL)
323e0a4a 1940 error (_("Bounds unavailable for null array pointer."));
529cad9c 1941 check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
1942 return value_ind (arrVal);
1943 }
ad82864c
JB
1944 else if (ada_is_constrained_packed_array_type (value_type (arr)))
1945 return decode_constrained_packed_array (arr);
d2e4a39e 1946 else
14f9c5c9
AS
1947 return arr;
1948}
1949
1950/* If TYPE represents a GNAT array type, return it translated to an
1951 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
1952 packing). For other types, is the identity. */
1953
d2e4a39e
AS
1954struct type *
1955ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 1956{
ad82864c
JB
1957 if (ada_is_constrained_packed_array_type (type))
1958 return decode_constrained_packed_array_type (type);
17280b9f
UW
1959
1960 if (ada_is_array_descriptor_type (type))
556bdfd4 1961 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
1962
1963 return type;
14f9c5c9
AS
1964}
1965
4c4b4cd2
PH
1966/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1967
ad82864c
JB
1968static int
1969ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
1970{
1971 if (type == NULL)
1972 return 0;
4c4b4cd2 1973 type = desc_base_type (type);
61ee279c 1974 type = ada_check_typedef (type);
d2e4a39e 1975 return
14f9c5c9
AS
1976 ada_type_name (type) != NULL
1977 && strstr (ada_type_name (type), "___XP") != NULL;
1978}
1979
ad82864c
JB
1980/* Non-zero iff TYPE represents a standard GNAT constrained
1981 packed-array type. */
1982
1983int
1984ada_is_constrained_packed_array_type (struct type *type)
1985{
1986 return ada_is_packed_array_type (type)
1987 && !ada_is_array_descriptor_type (type);
1988}
1989
1990/* Non-zero iff TYPE represents an array descriptor for a
1991 unconstrained packed-array type. */
1992
1993static int
1994ada_is_unconstrained_packed_array_type (struct type *type)
1995{
1996 return ada_is_packed_array_type (type)
1997 && ada_is_array_descriptor_type (type);
1998}
1999
2000/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2001 return the size of its elements in bits. */
2002
2003static long
2004decode_packed_array_bitsize (struct type *type)
2005{
0d5cff50
DE
2006 const char *raw_name;
2007 const char *tail;
ad82864c
JB
2008 long bits;
2009
720d1a40
JB
2010 /* Access to arrays implemented as fat pointers are encoded as a typedef
2011 of the fat pointer type. We need the name of the fat pointer type
2012 to do the decoding, so strip the typedef layer. */
2013 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2014 type = ada_typedef_target_type (type);
2015
2016 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2017 if (!raw_name)
2018 raw_name = ada_type_name (desc_base_type (type));
2019
2020 if (!raw_name)
2021 return 0;
2022
2023 tail = strstr (raw_name, "___XP");
720d1a40 2024 gdb_assert (tail != NULL);
ad82864c
JB
2025
2026 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2027 {
2028 lim_warning
2029 (_("could not understand bit size information on packed array"));
2030 return 0;
2031 }
2032
2033 return bits;
2034}
2035
14f9c5c9
AS
2036/* Given that TYPE is a standard GDB array type with all bounds filled
2037 in, and that the element size of its ultimate scalar constituents
2038 (that is, either its elements, or, if it is an array of arrays, its
2039 elements' elements, etc.) is *ELT_BITS, return an identical type,
2040 but with the bit sizes of its elements (and those of any
2041 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2
PH
2042 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2043 in bits. */
2044
d2e4a39e 2045static struct type *
ad82864c 2046constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2047{
d2e4a39e
AS
2048 struct type *new_elt_type;
2049 struct type *new_type;
99b1c762
JB
2050 struct type *index_type_desc;
2051 struct type *index_type;
14f9c5c9
AS
2052 LONGEST low_bound, high_bound;
2053
61ee279c 2054 type = ada_check_typedef (type);
14f9c5c9
AS
2055 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2056 return type;
2057
99b1c762
JB
2058 index_type_desc = ada_find_parallel_type (type, "___XA");
2059 if (index_type_desc)
2060 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2061 NULL);
2062 else
2063 index_type = TYPE_INDEX_TYPE (type);
2064
e9bb382b 2065 new_type = alloc_type_copy (type);
ad82864c
JB
2066 new_elt_type =
2067 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2068 elt_bits);
99b1c762 2069 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2070 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2071 TYPE_NAME (new_type) = ada_type_name (type);
2072
99b1c762 2073 if (get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2074 low_bound = high_bound = 0;
2075 if (high_bound < low_bound)
2076 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2077 else
14f9c5c9
AS
2078 {
2079 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2080 TYPE_LENGTH (new_type) =
4c4b4cd2 2081 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2082 }
2083
876cecd0 2084 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2085 return new_type;
2086}
2087
ad82864c
JB
2088/* The array type encoded by TYPE, where
2089 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2090
d2e4a39e 2091static struct type *
ad82864c 2092decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2093{
0d5cff50 2094 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2095 char *name;
0d5cff50 2096 const char *tail;
d2e4a39e 2097 struct type *shadow_type;
14f9c5c9 2098 long bits;
14f9c5c9 2099
727e3d2e
JB
2100 if (!raw_name)
2101 raw_name = ada_type_name (desc_base_type (type));
2102
2103 if (!raw_name)
2104 return NULL;
2105
2106 name = (char *) alloca (strlen (raw_name) + 1);
2107 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2108 type = desc_base_type (type);
2109
14f9c5c9
AS
2110 memcpy (name, raw_name, tail - raw_name);
2111 name[tail - raw_name] = '\000';
2112
b4ba55a1
JB
2113 shadow_type = ada_find_parallel_type_with_name (type, name);
2114
2115 if (shadow_type == NULL)
14f9c5c9 2116 {
323e0a4a 2117 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2118 return NULL;
2119 }
cb249c71 2120 CHECK_TYPEDEF (shadow_type);
14f9c5c9
AS
2121
2122 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2123 {
0963b4bd
MS
2124 lim_warning (_("could not understand bounds "
2125 "information on packed array"));
14f9c5c9
AS
2126 return NULL;
2127 }
d2e4a39e 2128
ad82864c
JB
2129 bits = decode_packed_array_bitsize (type);
2130 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2131}
2132
ad82864c
JB
2133/* Given that ARR is a struct value *indicating a GNAT constrained packed
2134 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2135 standard GDB array type except that the BITSIZEs of the array
2136 target types are set to the number of bits in each element, and the
4c4b4cd2 2137 type length is set appropriately. */
14f9c5c9 2138
d2e4a39e 2139static struct value *
ad82864c 2140decode_constrained_packed_array (struct value *arr)
14f9c5c9 2141{
4c4b4cd2 2142 struct type *type;
14f9c5c9 2143
4c4b4cd2 2144 arr = ada_coerce_ref (arr);
284614f0
JB
2145
2146 /* If our value is a pointer, then dererence it. Make sure that
2147 this operation does not cause the target type to be fixed, as
2148 this would indirectly cause this array to be decoded. The rest
2149 of the routine assumes that the array hasn't been decoded yet,
2150 so we use the basic "value_ind" routine to perform the dereferencing,
2151 as opposed to using "ada_value_ind". */
828292f2 2152 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2153 arr = value_ind (arr);
4c4b4cd2 2154
ad82864c 2155 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2156 if (type == NULL)
2157 {
323e0a4a 2158 error (_("can't unpack array"));
14f9c5c9
AS
2159 return NULL;
2160 }
61ee279c 2161
50810684 2162 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2163 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2164 {
2165 /* This is a (right-justified) modular type representing a packed
2166 array with no wrapper. In order to interpret the value through
2167 the (left-justified) packed array type we just built, we must
2168 first left-justify it. */
2169 int bit_size, bit_pos;
2170 ULONGEST mod;
2171
df407dfe 2172 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2173 bit_size = 0;
2174 while (mod > 0)
2175 {
2176 bit_size += 1;
2177 mod >>= 1;
2178 }
df407dfe 2179 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2180 arr = ada_value_primitive_packed_val (arr, NULL,
2181 bit_pos / HOST_CHAR_BIT,
2182 bit_pos % HOST_CHAR_BIT,
2183 bit_size,
2184 type);
2185 }
2186
4c4b4cd2 2187 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2188}
2189
2190
2191/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2192 given in IND. ARR must be a simple array. */
14f9c5c9 2193
d2e4a39e
AS
2194static struct value *
2195value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2196{
2197 int i;
2198 int bits, elt_off, bit_off;
2199 long elt_total_bit_offset;
d2e4a39e
AS
2200 struct type *elt_type;
2201 struct value *v;
14f9c5c9
AS
2202
2203 bits = 0;
2204 elt_total_bit_offset = 0;
df407dfe 2205 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2206 for (i = 0; i < arity; i += 1)
14f9c5c9 2207 {
d2e4a39e 2208 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2209 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2210 error
0963b4bd
MS
2211 (_("attempt to do packed indexing of "
2212 "something other than a packed array"));
14f9c5c9 2213 else
4c4b4cd2
PH
2214 {
2215 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2216 LONGEST lowerbound, upperbound;
2217 LONGEST idx;
2218
2219 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2220 {
323e0a4a 2221 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2222 lowerbound = upperbound = 0;
2223 }
2224
3cb382c9 2225 idx = pos_atr (ind[i]);
4c4b4cd2 2226 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2227 lim_warning (_("packed array index %ld out of bounds"),
2228 (long) idx);
4c4b4cd2
PH
2229 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2230 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2231 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2232 }
14f9c5c9
AS
2233 }
2234 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2235 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2236
2237 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2238 bits, elt_type);
14f9c5c9
AS
2239 return v;
2240}
2241
4c4b4cd2 2242/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2243
2244static int
d2e4a39e 2245has_negatives (struct type *type)
14f9c5c9 2246{
d2e4a39e
AS
2247 switch (TYPE_CODE (type))
2248 {
2249 default:
2250 return 0;
2251 case TYPE_CODE_INT:
2252 return !TYPE_UNSIGNED (type);
2253 case TYPE_CODE_RANGE:
2254 return TYPE_LOW_BOUND (type) < 0;
2255 }
14f9c5c9 2256}
d2e4a39e 2257
14f9c5c9
AS
2258
2259/* Create a new value of type TYPE from the contents of OBJ starting
2260 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2261 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
0963b4bd 2262 assigning through the result will set the field fetched from.
4c4b4cd2
PH
2263 VALADDR is ignored unless OBJ is NULL, in which case,
2264 VALADDR+OFFSET must address the start of storage containing the
2265 packed value. The value returned in this case is never an lval.
2266 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
14f9c5c9 2267
d2e4a39e 2268struct value *
fc1a4b47 2269ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
a2bd3dcd 2270 long offset, int bit_offset, int bit_size,
4c4b4cd2 2271 struct type *type)
14f9c5c9 2272{
d2e4a39e 2273 struct value *v;
4c4b4cd2
PH
2274 int src, /* Index into the source area */
2275 targ, /* Index into the target area */
2276 srcBitsLeft, /* Number of source bits left to move */
2277 nsrc, ntarg, /* Number of source and target bytes */
2278 unusedLS, /* Number of bits in next significant
2279 byte of source that are unused */
2280 accumSize; /* Number of meaningful bits in accum */
2281 unsigned char *bytes; /* First byte containing data to unpack */
d2e4a39e 2282 unsigned char *unpacked;
4c4b4cd2 2283 unsigned long accum; /* Staging area for bits being transferred */
14f9c5c9
AS
2284 unsigned char sign;
2285 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
4c4b4cd2
PH
2286 /* Transmit bytes from least to most significant; delta is the direction
2287 the indices move. */
50810684 2288 int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1;
14f9c5c9 2289
61ee279c 2290 type = ada_check_typedef (type);
14f9c5c9
AS
2291
2292 if (obj == NULL)
2293 {
2294 v = allocate_value (type);
d2e4a39e 2295 bytes = (unsigned char *) (valaddr + offset);
14f9c5c9 2296 }
9214ee5f 2297 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
14f9c5c9 2298 {
53ba8333 2299 v = value_at (type, value_address (obj));
d2e4a39e 2300 bytes = (unsigned char *) alloca (len);
53ba8333 2301 read_memory (value_address (v) + offset, bytes, len);
14f9c5c9 2302 }
d2e4a39e 2303 else
14f9c5c9
AS
2304 {
2305 v = allocate_value (type);
0fd88904 2306 bytes = (unsigned char *) value_contents (obj) + offset;
14f9c5c9 2307 }
d2e4a39e
AS
2308
2309 if (obj != NULL)
14f9c5c9 2310 {
53ba8333 2311 long new_offset = offset;
5b4ee69b 2312
74bcbdf3 2313 set_value_component_location (v, obj);
9bbda503
AC
2314 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2315 set_value_bitsize (v, bit_size);
df407dfe 2316 if (value_bitpos (v) >= HOST_CHAR_BIT)
4c4b4cd2 2317 {
53ba8333 2318 ++new_offset;
9bbda503 2319 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
4c4b4cd2 2320 }
53ba8333
JB
2321 set_value_offset (v, new_offset);
2322
2323 /* Also set the parent value. This is needed when trying to
2324 assign a new value (in inferior memory). */
2325 set_value_parent (v, obj);
14f9c5c9
AS
2326 }
2327 else
9bbda503 2328 set_value_bitsize (v, bit_size);
0fd88904 2329 unpacked = (unsigned char *) value_contents (v);
14f9c5c9
AS
2330
2331 srcBitsLeft = bit_size;
2332 nsrc = len;
2333 ntarg = TYPE_LENGTH (type);
2334 sign = 0;
2335 if (bit_size == 0)
2336 {
2337 memset (unpacked, 0, TYPE_LENGTH (type));
2338 return v;
2339 }
50810684 2340 else if (gdbarch_bits_big_endian (get_type_arch (type)))
14f9c5c9 2341 {
d2e4a39e 2342 src = len - 1;
1265e4aa
JB
2343 if (has_negatives (type)
2344 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2345 sign = ~0;
d2e4a39e
AS
2346
2347 unusedLS =
4c4b4cd2
PH
2348 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2349 % HOST_CHAR_BIT;
14f9c5c9
AS
2350
2351 switch (TYPE_CODE (type))
4c4b4cd2
PH
2352 {
2353 case TYPE_CODE_ARRAY:
2354 case TYPE_CODE_UNION:
2355 case TYPE_CODE_STRUCT:
2356 /* Non-scalar values must be aligned at a byte boundary... */
2357 accumSize =
2358 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2359 /* ... And are placed at the beginning (most-significant) bytes
2360 of the target. */
529cad9c 2361 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
0056e4d5 2362 ntarg = targ + 1;
4c4b4cd2
PH
2363 break;
2364 default:
2365 accumSize = 0;
2366 targ = TYPE_LENGTH (type) - 1;
2367 break;
2368 }
14f9c5c9 2369 }
d2e4a39e 2370 else
14f9c5c9
AS
2371 {
2372 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2373
2374 src = targ = 0;
2375 unusedLS = bit_offset;
2376 accumSize = 0;
2377
d2e4a39e 2378 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2379 sign = ~0;
14f9c5c9 2380 }
d2e4a39e 2381
14f9c5c9
AS
2382 accum = 0;
2383 while (nsrc > 0)
2384 {
2385 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2386 part of the value. */
d2e4a39e 2387 unsigned int unusedMSMask =
4c4b4cd2
PH
2388 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2389 1;
2390 /* Sign-extend bits for this byte. */
14f9c5c9 2391 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2392
d2e4a39e 2393 accum |=
4c4b4cd2 2394 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2395 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2396 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2
PH
2397 {
2398 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2399 accumSize -= HOST_CHAR_BIT;
2400 accum >>= HOST_CHAR_BIT;
2401 ntarg -= 1;
2402 targ += delta;
2403 }
14f9c5c9
AS
2404 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2405 unusedLS = 0;
2406 nsrc -= 1;
2407 src += delta;
2408 }
2409 while (ntarg > 0)
2410 {
2411 accum |= sign << accumSize;
2412 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2413 accumSize -= HOST_CHAR_BIT;
2414 accum >>= HOST_CHAR_BIT;
2415 ntarg -= 1;
2416 targ += delta;
2417 }
2418
2419 return v;
2420}
d2e4a39e 2421
14f9c5c9
AS
2422/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2423 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2424 not overlap. */
14f9c5c9 2425static void
fc1a4b47 2426move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2427 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2428{
2429 unsigned int accum, mask;
2430 int accum_bits, chunk_size;
2431
2432 target += targ_offset / HOST_CHAR_BIT;
2433 targ_offset %= HOST_CHAR_BIT;
2434 source += src_offset / HOST_CHAR_BIT;
2435 src_offset %= HOST_CHAR_BIT;
50810684 2436 if (bits_big_endian_p)
14f9c5c9
AS
2437 {
2438 accum = (unsigned char) *source;
2439 source += 1;
2440 accum_bits = HOST_CHAR_BIT - src_offset;
2441
d2e4a39e 2442 while (n > 0)
4c4b4cd2
PH
2443 {
2444 int unused_right;
5b4ee69b 2445
4c4b4cd2
PH
2446 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2447 accum_bits += HOST_CHAR_BIT;
2448 source += 1;
2449 chunk_size = HOST_CHAR_BIT - targ_offset;
2450 if (chunk_size > n)
2451 chunk_size = n;
2452 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2453 mask = ((1 << chunk_size) - 1) << unused_right;
2454 *target =
2455 (*target & ~mask)
2456 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2457 n -= chunk_size;
2458 accum_bits -= chunk_size;
2459 target += 1;
2460 targ_offset = 0;
2461 }
14f9c5c9
AS
2462 }
2463 else
2464 {
2465 accum = (unsigned char) *source >> src_offset;
2466 source += 1;
2467 accum_bits = HOST_CHAR_BIT - src_offset;
2468
d2e4a39e 2469 while (n > 0)
4c4b4cd2
PH
2470 {
2471 accum = accum + ((unsigned char) *source << accum_bits);
2472 accum_bits += HOST_CHAR_BIT;
2473 source += 1;
2474 chunk_size = HOST_CHAR_BIT - targ_offset;
2475 if (chunk_size > n)
2476 chunk_size = n;
2477 mask = ((1 << chunk_size) - 1) << targ_offset;
2478 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2479 n -= chunk_size;
2480 accum_bits -= chunk_size;
2481 accum >>= chunk_size;
2482 target += 1;
2483 targ_offset = 0;
2484 }
14f9c5c9
AS
2485 }
2486}
2487
14f9c5c9
AS
2488/* Store the contents of FROMVAL into the location of TOVAL.
2489 Return a new value with the location of TOVAL and contents of
2490 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2491 floating-point or non-scalar types. */
14f9c5c9 2492
d2e4a39e
AS
2493static struct value *
2494ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2495{
df407dfe
AC
2496 struct type *type = value_type (toval);
2497 int bits = value_bitsize (toval);
14f9c5c9 2498
52ce6436
PH
2499 toval = ada_coerce_ref (toval);
2500 fromval = ada_coerce_ref (fromval);
2501
2502 if (ada_is_direct_array_type (value_type (toval)))
2503 toval = ada_coerce_to_simple_array (toval);
2504 if (ada_is_direct_array_type (value_type (fromval)))
2505 fromval = ada_coerce_to_simple_array (fromval);
2506
88e3b34b 2507 if (!deprecated_value_modifiable (toval))
323e0a4a 2508 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2509
d2e4a39e 2510 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2511 && bits > 0
d2e4a39e 2512 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2513 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2514 {
df407dfe
AC
2515 int len = (value_bitpos (toval)
2516 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2517 int from_size;
948f8e3d 2518 gdb_byte *buffer = alloca (len);
d2e4a39e 2519 struct value *val;
42ae5230 2520 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2521
2522 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2523 fromval = value_cast (type, fromval);
14f9c5c9 2524
52ce6436 2525 read_memory (to_addr, buffer, len);
aced2898
PH
2526 from_size = value_bitsize (fromval);
2527 if (from_size == 0)
2528 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2529 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2530 move_bits (buffer, value_bitpos (toval),
50810684 2531 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2532 else
50810684
UW
2533 move_bits (buffer, value_bitpos (toval),
2534 value_contents (fromval), 0, bits, 0);
972daa01 2535 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2536
14f9c5c9 2537 val = value_copy (toval);
0fd88904 2538 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2539 TYPE_LENGTH (type));
04624583 2540 deprecated_set_value_type (val, type);
d2e4a39e 2541
14f9c5c9
AS
2542 return val;
2543 }
2544
2545 return value_assign (toval, fromval);
2546}
2547
2548
52ce6436
PH
2549/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2550 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2551 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2552 * COMPONENT, and not the inferior's memory. The current contents
2553 * of COMPONENT are ignored. */
2554static void
2555value_assign_to_component (struct value *container, struct value *component,
2556 struct value *val)
2557{
2558 LONGEST offset_in_container =
42ae5230 2559 (LONGEST) (value_address (component) - value_address (container));
52ce6436
PH
2560 int bit_offset_in_container =
2561 value_bitpos (component) - value_bitpos (container);
2562 int bits;
2563
2564 val = value_cast (value_type (component), val);
2565
2566 if (value_bitsize (component) == 0)
2567 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2568 else
2569 bits = value_bitsize (component);
2570
50810684 2571 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
52ce6436
PH
2572 move_bits (value_contents_writeable (container) + offset_in_container,
2573 value_bitpos (container) + bit_offset_in_container,
2574 value_contents (val),
2575 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
50810684 2576 bits, 1);
52ce6436
PH
2577 else
2578 move_bits (value_contents_writeable (container) + offset_in_container,
2579 value_bitpos (container) + bit_offset_in_container,
50810684 2580 value_contents (val), 0, bits, 0);
52ce6436
PH
2581}
2582
4c4b4cd2
PH
2583/* The value of the element of array ARR at the ARITY indices given in IND.
2584 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2585 thereto. */
2586
d2e4a39e
AS
2587struct value *
2588ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2589{
2590 int k;
d2e4a39e
AS
2591 struct value *elt;
2592 struct type *elt_type;
14f9c5c9
AS
2593
2594 elt = ada_coerce_to_simple_array (arr);
2595
df407dfe 2596 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2597 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2598 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2599 return value_subscript_packed (elt, arity, ind);
2600
2601 for (k = 0; k < arity; k += 1)
2602 {
2603 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2604 error (_("too many subscripts (%d expected)"), k);
2497b498 2605 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2606 }
2607 return elt;
2608}
2609
2610/* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2611 value of the element of *ARR at the ARITY indices given in
4c4b4cd2 2612 IND. Does not read the entire array into memory. */
14f9c5c9 2613
2c0b251b 2614static struct value *
d2e4a39e 2615ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
4c4b4cd2 2616 struct value **ind)
14f9c5c9
AS
2617{
2618 int k;
2619
2620 for (k = 0; k < arity; k += 1)
2621 {
2622 LONGEST lwb, upb;
14f9c5c9
AS
2623
2624 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2625 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2626 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2627 value_copy (arr));
14f9c5c9 2628 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2497b498 2629 arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
14f9c5c9
AS
2630 type = TYPE_TARGET_TYPE (type);
2631 }
2632
2633 return value_ind (arr);
2634}
2635
0b5d8877 2636/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
f5938064
JG
2637 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2638 elements starting at index LOW. The lower bound of this array is LOW, as
0963b4bd 2639 per Ada rules. */
0b5d8877 2640static struct value *
f5938064
JG
2641ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2642 int low, int high)
0b5d8877 2643{
b0dd7688 2644 struct type *type0 = ada_check_typedef (type);
6c038f32 2645 CORE_ADDR base = value_as_address (array_ptr)
b0dd7688
JB
2646 + ((low - ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0)))
2647 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
6c038f32 2648 struct type *index_type =
b0dd7688 2649 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)),
0b5d8877 2650 low, high);
6c038f32 2651 struct type *slice_type =
b0dd7688 2652 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
5b4ee69b 2653
f5938064 2654 return value_at_lazy (slice_type, base);
0b5d8877
PH
2655}
2656
2657
2658static struct value *
2659ada_value_slice (struct value *array, int low, int high)
2660{
b0dd7688 2661 struct type *type = ada_check_typedef (value_type (array));
6c038f32 2662 struct type *index_type =
0b5d8877 2663 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
6c038f32 2664 struct type *slice_type =
0b5d8877 2665 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
5b4ee69b 2666
6c038f32 2667 return value_cast (slice_type, value_slice (array, low, high - low + 1));
0b5d8877
PH
2668}
2669
14f9c5c9
AS
2670/* If type is a record type in the form of a standard GNAT array
2671 descriptor, returns the number of dimensions for type. If arr is a
2672 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2673 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2674
2675int
d2e4a39e 2676ada_array_arity (struct type *type)
14f9c5c9
AS
2677{
2678 int arity;
2679
2680 if (type == NULL)
2681 return 0;
2682
2683 type = desc_base_type (type);
2684
2685 arity = 0;
d2e4a39e 2686 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2687 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2688 else
2689 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2690 {
4c4b4cd2 2691 arity += 1;
61ee279c 2692 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2693 }
d2e4a39e 2694
14f9c5c9
AS
2695 return arity;
2696}
2697
2698/* If TYPE is a record type in the form of a standard GNAT array
2699 descriptor or a simple array type, returns the element type for
2700 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2701 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2702
d2e4a39e
AS
2703struct type *
2704ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2705{
2706 type = desc_base_type (type);
2707
d2e4a39e 2708 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2709 {
2710 int k;
d2e4a39e 2711 struct type *p_array_type;
14f9c5c9 2712
556bdfd4 2713 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
2714
2715 k = ada_array_arity (type);
2716 if (k == 0)
4c4b4cd2 2717 return NULL;
d2e4a39e 2718
4c4b4cd2 2719 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2720 if (nindices >= 0 && k > nindices)
4c4b4cd2 2721 k = nindices;
d2e4a39e 2722 while (k > 0 && p_array_type != NULL)
4c4b4cd2 2723 {
61ee279c 2724 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
2725 k -= 1;
2726 }
14f9c5c9
AS
2727 return p_array_type;
2728 }
2729 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2730 {
2731 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
2732 {
2733 type = TYPE_TARGET_TYPE (type);
2734 nindices -= 1;
2735 }
14f9c5c9
AS
2736 return type;
2737 }
2738
2739 return NULL;
2740}
2741
4c4b4cd2 2742/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
2743 Does not examine memory. Throws an error if N is invalid or TYPE
2744 is not an array type. NAME is the name of the Ada attribute being
2745 evaluated ('range, 'first, 'last, or 'length); it is used in building
2746 the error message. */
14f9c5c9 2747
1eea4ebd
UW
2748static struct type *
2749ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 2750{
4c4b4cd2
PH
2751 struct type *result_type;
2752
14f9c5c9
AS
2753 type = desc_base_type (type);
2754
1eea4ebd
UW
2755 if (n < 0 || n > ada_array_arity (type))
2756 error (_("invalid dimension number to '%s"), name);
14f9c5c9 2757
4c4b4cd2 2758 if (ada_is_simple_array_type (type))
14f9c5c9
AS
2759 {
2760 int i;
2761
2762 for (i = 1; i < n; i += 1)
4c4b4cd2 2763 type = TYPE_TARGET_TYPE (type);
262452ec 2764 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
2765 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2766 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 2767 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
2768 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2769 result_type = NULL;
14f9c5c9 2770 }
d2e4a39e 2771 else
1eea4ebd
UW
2772 {
2773 result_type = desc_index_type (desc_bounds_type (type), n);
2774 if (result_type == NULL)
2775 error (_("attempt to take bound of something that is not an array"));
2776 }
2777
2778 return result_type;
14f9c5c9
AS
2779}
2780
2781/* Given that arr is an array type, returns the lower bound of the
2782 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 2783 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
2784 array-descriptor type. It works for other arrays with bounds supplied
2785 by run-time quantities other than discriminants. */
14f9c5c9 2786
abb68b3e 2787static LONGEST
fb5e3d5c 2788ada_array_bound_from_type (struct type *arr_type, int n, int which)
14f9c5c9 2789{
8a48ac95 2790 struct type *type, *index_type_desc, *index_type;
1ce677a4 2791 int i;
262452ec
JK
2792
2793 gdb_assert (which == 0 || which == 1);
14f9c5c9 2794
ad82864c
JB
2795 if (ada_is_constrained_packed_array_type (arr_type))
2796 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 2797
4c4b4cd2 2798 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 2799 return (LONGEST) - which;
14f9c5c9
AS
2800
2801 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2802 type = TYPE_TARGET_TYPE (arr_type);
2803 else
2804 type = arr_type;
2805
2806 index_type_desc = ada_find_parallel_type (type, "___XA");
28c85d6c 2807 ada_fixup_array_indexes_type (index_type_desc);
262452ec 2808 if (index_type_desc != NULL)
28c85d6c
JB
2809 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
2810 NULL);
262452ec 2811 else
8a48ac95
JB
2812 {
2813 struct type *elt_type = check_typedef (type);
2814
2815 for (i = 1; i < n; i++)
2816 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
2817
2818 index_type = TYPE_INDEX_TYPE (elt_type);
2819 }
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
bb4142cf 5867 expand_symtabs_matching 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
bb4142cf
DE
5879/* A callback for expand_symtabs_matching. */
5880
7b08b9eb 5881static int
bb4142cf 5882ada_complete_symbol_matcher (const char *name, void *user_data)
ccefe4c4
TT
5883{
5884 struct add_partial_datum *data = user_data;
7b08b9eb
JK
5885
5886 return symbol_completion_match (name, data->text, data->text_len,
5887 data->wild_match, data->encoded) != NULL;
ccefe4c4
TT
5888}
5889
49c4e619
TT
5890/* Return a list of possible symbol names completing TEXT0. WORD is
5891 the entire command on which completion is made. */
41d27058 5892
49c4e619 5893static VEC (char_ptr) *
6f937416
PA
5894ada_make_symbol_completion_list (const char *text0, const char *word,
5895 enum type_code code)
41d27058
JB
5896{
5897 char *text;
5898 int text_len;
b1ed564a
JB
5899 int wild_match_p;
5900 int encoded_p;
2ba95b9b 5901 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
41d27058
JB
5902 struct symbol *sym;
5903 struct symtab *s;
41d27058
JB
5904 struct minimal_symbol *msymbol;
5905 struct objfile *objfile;
5906 struct block *b, *surrounding_static_block = 0;
5907 int i;
8157b174 5908 struct block_iterator iter;
b8fea896 5909 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
41d27058 5910
2f68a895
TT
5911 gdb_assert (code == TYPE_CODE_UNDEF);
5912
41d27058
JB
5913 if (text0[0] == '<')
5914 {
5915 text = xstrdup (text0);
5916 make_cleanup (xfree, text);
5917 text_len = strlen (text);
b1ed564a
JB
5918 wild_match_p = 0;
5919 encoded_p = 1;
41d27058
JB
5920 }
5921 else
5922 {
5923 text = xstrdup (ada_encode (text0));
5924 make_cleanup (xfree, text);
5925 text_len = strlen (text);
5926 for (i = 0; i < text_len; i++)
5927 text[i] = tolower (text[i]);
5928
b1ed564a 5929 encoded_p = (strstr (text0, "__") != NULL);
41d27058
JB
5930 /* If the name contains a ".", then the user is entering a fully
5931 qualified entity name, and the match must not be done in wild
5932 mode. Similarly, if the user wants to complete what looks like
5933 an encoded name, the match must not be done in wild mode. */
b1ed564a 5934 wild_match_p = (strchr (text0, '.') == NULL && !encoded_p);
41d27058
JB
5935 }
5936
5937 /* First, look at the partial symtab symbols. */
41d27058 5938 {
ccefe4c4
TT
5939 struct add_partial_datum data;
5940
5941 data.completions = &completions;
5942 data.text = text;
5943 data.text_len = text_len;
5944 data.text0 = text0;
5945 data.word = word;
b1ed564a
JB
5946 data.wild_match = wild_match_p;
5947 data.encoded = encoded_p;
bb4142cf
DE
5948 expand_symtabs_matching (NULL, ada_complete_symbol_matcher, ALL_DOMAIN,
5949 &data);
41d27058
JB
5950 }
5951
5952 /* At this point scan through the misc symbol vectors and add each
5953 symbol you find to the list. Eventually we want to ignore
5954 anything that isn't a text symbol (everything else will be
5955 handled by the psymtab code above). */
5956
5957 ALL_MSYMBOLS (objfile, msymbol)
5958 {
5959 QUIT;
d6565258 5960 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol),
b1ed564a
JB
5961 text, text_len, text0, word, wild_match_p,
5962 encoded_p);
41d27058
JB
5963 }
5964
5965 /* Search upwards from currently selected frame (so that we can
5966 complete on local vars. */
5967
5968 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
5969 {
5970 if (!BLOCK_SUPERBLOCK (b))
5971 surrounding_static_block = b; /* For elmin of dups */
5972
5973 ALL_BLOCK_SYMBOLS (b, iter, sym)
5974 {
d6565258 5975 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 5976 text, text_len, text0, word,
b1ed564a 5977 wild_match_p, encoded_p);
41d27058
JB
5978 }
5979 }
5980
5981 /* Go through the symtabs and check the externs and statics for
5982 symbols which match. */
5983
5984 ALL_SYMTABS (objfile, s)
5985 {
5986 QUIT;
5987 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
5988 ALL_BLOCK_SYMBOLS (b, iter, sym)
5989 {
d6565258 5990 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 5991 text, text_len, text0, word,
b1ed564a 5992 wild_match_p, encoded_p);
41d27058
JB
5993 }
5994 }
5995
5996 ALL_SYMTABS (objfile, s)
5997 {
5998 QUIT;
5999 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
6000 /* Don't do this block twice. */
6001 if (b == surrounding_static_block)
6002 continue;
6003 ALL_BLOCK_SYMBOLS (b, iter, sym)
6004 {
d6565258 6005 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6006 text, text_len, text0, word,
b1ed564a 6007 wild_match_p, encoded_p);
41d27058
JB
6008 }
6009 }
6010
b8fea896 6011 do_cleanups (old_chain);
49c4e619 6012 return completions;
41d27058
JB
6013}
6014
963a6417 6015 /* Field Access */
96d887e8 6016
73fb9985
JB
6017/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6018 for tagged types. */
6019
6020static int
6021ada_is_dispatch_table_ptr_type (struct type *type)
6022{
0d5cff50 6023 const char *name;
73fb9985
JB
6024
6025 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6026 return 0;
6027
6028 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6029 if (name == NULL)
6030 return 0;
6031
6032 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6033}
6034
ac4a2da4
JG
6035/* Return non-zero if TYPE is an interface tag. */
6036
6037static int
6038ada_is_interface_tag (struct type *type)
6039{
6040 const char *name = TYPE_NAME (type);
6041
6042 if (name == NULL)
6043 return 0;
6044
6045 return (strcmp (name, "ada__tags__interface_tag") == 0);
6046}
6047
963a6417
PH
6048/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6049 to be invisible to users. */
96d887e8 6050
963a6417
PH
6051int
6052ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6053{
963a6417
PH
6054 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6055 return 1;
ffde82bf 6056
73fb9985
JB
6057 /* Check the name of that field. */
6058 {
6059 const char *name = TYPE_FIELD_NAME (type, field_num);
6060
6061 /* Anonymous field names should not be printed.
6062 brobecker/2007-02-20: I don't think this can actually happen
6063 but we don't want to print the value of annonymous fields anyway. */
6064 if (name == NULL)
6065 return 1;
6066
ffde82bf
JB
6067 /* Normally, fields whose name start with an underscore ("_")
6068 are fields that have been internally generated by the compiler,
6069 and thus should not be printed. The "_parent" field is special,
6070 however: This is a field internally generated by the compiler
6071 for tagged types, and it contains the components inherited from
6072 the parent type. This field should not be printed as is, but
6073 should not be ignored either. */
73fb9985
JB
6074 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
6075 return 1;
6076 }
6077
ac4a2da4
JG
6078 /* If this is the dispatch table of a tagged type or an interface tag,
6079 then ignore. */
73fb9985 6080 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6081 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6082 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6083 return 1;
6084
6085 /* Not a special field, so it should not be ignored. */
6086 return 0;
963a6417 6087}
96d887e8 6088
963a6417 6089/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6090 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6091
963a6417
PH
6092int
6093ada_is_tagged_type (struct type *type, int refok)
6094{
6095 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
6096}
96d887e8 6097
963a6417 6098/* True iff TYPE represents the type of X'Tag */
96d887e8 6099
963a6417
PH
6100int
6101ada_is_tag_type (struct type *type)
6102{
6103 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6104 return 0;
6105 else
96d887e8 6106 {
963a6417 6107 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6108
963a6417
PH
6109 return (name != NULL
6110 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6111 }
96d887e8
PH
6112}
6113
963a6417 6114/* The type of the tag on VAL. */
76a01679 6115
963a6417
PH
6116struct type *
6117ada_tag_type (struct value *val)
96d887e8 6118{
df407dfe 6119 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
963a6417 6120}
96d887e8 6121
b50d69b5
JG
6122/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6123 retired at Ada 05). */
6124
6125static int
6126is_ada95_tag (struct value *tag)
6127{
6128 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6129}
6130
963a6417 6131/* The value of the tag on VAL. */
96d887e8 6132
963a6417
PH
6133struct value *
6134ada_value_tag (struct value *val)
6135{
03ee6b2e 6136 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6137}
6138
963a6417
PH
6139/* The value of the tag on the object of type TYPE whose contents are
6140 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6141 ADDRESS. */
96d887e8 6142
963a6417 6143static struct value *
10a2c479 6144value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6145 const gdb_byte *valaddr,
963a6417 6146 CORE_ADDR address)
96d887e8 6147{
b5385fc0 6148 int tag_byte_offset;
963a6417 6149 struct type *tag_type;
5b4ee69b 6150
963a6417 6151 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6152 NULL, NULL, NULL))
96d887e8 6153 {
fc1a4b47 6154 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6155 ? NULL
6156 : valaddr + tag_byte_offset);
963a6417 6157 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6158
963a6417 6159 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6160 }
963a6417
PH
6161 return NULL;
6162}
96d887e8 6163
963a6417
PH
6164static struct type *
6165type_from_tag (struct value *tag)
6166{
6167 const char *type_name = ada_tag_name (tag);
5b4ee69b 6168
963a6417
PH
6169 if (type_name != NULL)
6170 return ada_find_any_type (ada_encode (type_name));
6171 return NULL;
6172}
96d887e8 6173
b50d69b5
JG
6174/* Given a value OBJ of a tagged type, return a value of this
6175 type at the base address of the object. The base address, as
6176 defined in Ada.Tags, it is the address of the primary tag of
6177 the object, and therefore where the field values of its full
6178 view can be fetched. */
6179
6180struct value *
6181ada_tag_value_at_base_address (struct value *obj)
6182{
6183 volatile struct gdb_exception e;
6184 struct value *val;
6185 LONGEST offset_to_top = 0;
6186 struct type *ptr_type, *obj_type;
6187 struct value *tag;
6188 CORE_ADDR base_address;
6189
6190 obj_type = value_type (obj);
6191
6192 /* It is the responsability of the caller to deref pointers. */
6193
6194 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6195 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6196 return obj;
6197
6198 tag = ada_value_tag (obj);
6199 if (!tag)
6200 return obj;
6201
6202 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6203
6204 if (is_ada95_tag (tag))
6205 return obj;
6206
6207 ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
6208 ptr_type = lookup_pointer_type (ptr_type);
6209 val = value_cast (ptr_type, tag);
6210 if (!val)
6211 return obj;
6212
6213 /* It is perfectly possible that an exception be raised while
6214 trying to determine the base address, just like for the tag;
6215 see ada_tag_name for more details. We do not print the error
6216 message for the same reason. */
6217
6218 TRY_CATCH (e, RETURN_MASK_ERROR)
6219 {
6220 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6221 }
6222
6223 if (e.reason < 0)
6224 return obj;
6225
6226 /* If offset is null, nothing to do. */
6227
6228 if (offset_to_top == 0)
6229 return obj;
6230
6231 /* -1 is a special case in Ada.Tags; however, what should be done
6232 is not quite clear from the documentation. So do nothing for
6233 now. */
6234
6235 if (offset_to_top == -1)
6236 return obj;
6237
6238 base_address = value_address (obj) - offset_to_top;
6239 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6240
6241 /* Make sure that we have a proper tag at the new address.
6242 Otherwise, offset_to_top is bogus (which can happen when
6243 the object is not initialized yet). */
6244
6245 if (!tag)
6246 return obj;
6247
6248 obj_type = type_from_tag (tag);
6249
6250 if (!obj_type)
6251 return obj;
6252
6253 return value_from_contents_and_address (obj_type, NULL, base_address);
6254}
6255
1b611343
JB
6256/* Return the "ada__tags__type_specific_data" type. */
6257
6258static struct type *
6259ada_get_tsd_type (struct inferior *inf)
963a6417 6260{
1b611343 6261 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6262
1b611343
JB
6263 if (data->tsd_type == 0)
6264 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6265 return data->tsd_type;
6266}
529cad9c 6267
1b611343
JB
6268/* Return the TSD (type-specific data) associated to the given TAG.
6269 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6270
1b611343 6271 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6272
1b611343
JB
6273static struct value *
6274ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6275{
4c4b4cd2 6276 struct value *val;
1b611343 6277 struct type *type;
5b4ee69b 6278
1b611343
JB
6279 /* First option: The TSD is simply stored as a field of our TAG.
6280 Only older versions of GNAT would use this format, but we have
6281 to test it first, because there are no visible markers for
6282 the current approach except the absence of that field. */
529cad9c 6283
1b611343
JB
6284 val = ada_value_struct_elt (tag, "tsd", 1);
6285 if (val)
6286 return val;
e802dbe0 6287
1b611343
JB
6288 /* Try the second representation for the dispatch table (in which
6289 there is no explicit 'tsd' field in the referent of the tag pointer,
6290 and instead the tsd pointer is stored just before the dispatch
6291 table. */
e802dbe0 6292
1b611343
JB
6293 type = ada_get_tsd_type (current_inferior());
6294 if (type == NULL)
6295 return NULL;
6296 type = lookup_pointer_type (lookup_pointer_type (type));
6297 val = value_cast (type, tag);
6298 if (val == NULL)
6299 return NULL;
6300 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6301}
6302
1b611343
JB
6303/* Given the TSD of a tag (type-specific data), return a string
6304 containing the name of the associated type.
6305
6306 The returned value is good until the next call. May return NULL
6307 if we are unable to determine the tag name. */
6308
6309static char *
6310ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6311{
529cad9c
PH
6312 static char name[1024];
6313 char *p;
1b611343 6314 struct value *val;
529cad9c 6315
1b611343 6316 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6317 if (val == NULL)
1b611343 6318 return NULL;
4c4b4cd2
PH
6319 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6320 for (p = name; *p != '\0'; p += 1)
6321 if (isalpha (*p))
6322 *p = tolower (*p);
1b611343 6323 return name;
4c4b4cd2
PH
6324}
6325
6326/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6327 a C string.
6328
6329 Return NULL if the TAG is not an Ada tag, or if we were unable to
6330 determine the name of that tag. The result is good until the next
6331 call. */
4c4b4cd2
PH
6332
6333const char *
6334ada_tag_name (struct value *tag)
6335{
1b611343
JB
6336 volatile struct gdb_exception e;
6337 char *name = NULL;
5b4ee69b 6338
df407dfe 6339 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6340 return NULL;
1b611343
JB
6341
6342 /* It is perfectly possible that an exception be raised while trying
6343 to determine the TAG's name, even under normal circumstances:
6344 The associated variable may be uninitialized or corrupted, for
6345 instance. We do not let any exception propagate past this point.
6346 instead we return NULL.
6347
6348 We also do not print the error message either (which often is very
6349 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6350 the caller print a more meaningful message if necessary. */
6351 TRY_CATCH (e, RETURN_MASK_ERROR)
6352 {
6353 struct value *tsd = ada_get_tsd_from_tag (tag);
6354
6355 if (tsd != NULL)
6356 name = ada_tag_name_from_tsd (tsd);
6357 }
6358
6359 return name;
4c4b4cd2
PH
6360}
6361
6362/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6363
d2e4a39e 6364struct type *
ebf56fd3 6365ada_parent_type (struct type *type)
14f9c5c9
AS
6366{
6367 int i;
6368
61ee279c 6369 type = ada_check_typedef (type);
14f9c5c9
AS
6370
6371 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6372 return NULL;
6373
6374 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6375 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6376 {
6377 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6378
6379 /* If the _parent field is a pointer, then dereference it. */
6380 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6381 parent_type = TYPE_TARGET_TYPE (parent_type);
6382 /* If there is a parallel XVS type, get the actual base type. */
6383 parent_type = ada_get_base_type (parent_type);
6384
6385 return ada_check_typedef (parent_type);
6386 }
14f9c5c9
AS
6387
6388 return NULL;
6389}
6390
4c4b4cd2
PH
6391/* True iff field number FIELD_NUM of structure type TYPE contains the
6392 parent-type (inherited) fields of a derived type. Assumes TYPE is
6393 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6394
6395int
ebf56fd3 6396ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6397{
61ee279c 6398 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6399
4c4b4cd2
PH
6400 return (name != NULL
6401 && (strncmp (name, "PARENT", 6) == 0
6402 || strncmp (name, "_parent", 7) == 0));
14f9c5c9
AS
6403}
6404
4c4b4cd2 6405/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6406 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6407 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6408 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6409 structures. */
14f9c5c9
AS
6410
6411int
ebf56fd3 6412ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6413{
d2e4a39e 6414 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6415
d2e4a39e 6416 return (name != NULL
4c4b4cd2
PH
6417 && (strncmp (name, "PARENT", 6) == 0
6418 || strcmp (name, "REP") == 0
6419 || strncmp (name, "_parent", 7) == 0
6420 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6421}
6422
4c4b4cd2
PH
6423/* True iff field number FIELD_NUM of structure or union type TYPE
6424 is a variant wrapper. Assumes TYPE is a structure type with at least
6425 FIELD_NUM+1 fields. */
14f9c5c9
AS
6426
6427int
ebf56fd3 6428ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6429{
d2e4a39e 6430 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6431
14f9c5c9 6432 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6433 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6434 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6435 == TYPE_CODE_UNION)));
14f9c5c9
AS
6436}
6437
6438/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6439 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6440 returns the type of the controlling discriminant for the variant.
6441 May return NULL if the type could not be found. */
14f9c5c9 6442
d2e4a39e 6443struct type *
ebf56fd3 6444ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6445{
d2e4a39e 6446 char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6447
7c964f07 6448 return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
14f9c5c9
AS
6449}
6450
4c4b4cd2 6451/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6452 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6453 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6454
6455int
ebf56fd3 6456ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6457{
d2e4a39e 6458 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6459
14f9c5c9
AS
6460 return (name != NULL && name[0] == 'O');
6461}
6462
6463/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
6464 returns the name of the discriminant controlling the variant.
6465 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 6466
d2e4a39e 6467char *
ebf56fd3 6468ada_variant_discrim_name (struct type *type0)
14f9c5c9 6469{
d2e4a39e 6470 static char *result = NULL;
14f9c5c9 6471 static size_t result_len = 0;
d2e4a39e
AS
6472 struct type *type;
6473 const char *name;
6474 const char *discrim_end;
6475 const char *discrim_start;
14f9c5c9
AS
6476
6477 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6478 type = TYPE_TARGET_TYPE (type0);
6479 else
6480 type = type0;
6481
6482 name = ada_type_name (type);
6483
6484 if (name == NULL || name[0] == '\000')
6485 return "";
6486
6487 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6488 discrim_end -= 1)
6489 {
4c4b4cd2
PH
6490 if (strncmp (discrim_end, "___XVN", 6) == 0)
6491 break;
14f9c5c9
AS
6492 }
6493 if (discrim_end == name)
6494 return "";
6495
d2e4a39e 6496 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
6497 discrim_start -= 1)
6498 {
d2e4a39e 6499 if (discrim_start == name + 1)
4c4b4cd2 6500 return "";
76a01679 6501 if ((discrim_start > name + 3
4c4b4cd2
PH
6502 && strncmp (discrim_start - 3, "___", 3) == 0)
6503 || discrim_start[-1] == '.')
6504 break;
14f9c5c9
AS
6505 }
6506
6507 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6508 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 6509 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
6510 return result;
6511}
6512
4c4b4cd2
PH
6513/* Scan STR for a subtype-encoded number, beginning at position K.
6514 Put the position of the character just past the number scanned in
6515 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6516 Return 1 if there was a valid number at the given position, and 0
6517 otherwise. A "subtype-encoded" number consists of the absolute value
6518 in decimal, followed by the letter 'm' to indicate a negative number.
6519 Assumes 0m does not occur. */
14f9c5c9
AS
6520
6521int
d2e4a39e 6522ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
6523{
6524 ULONGEST RU;
6525
d2e4a39e 6526 if (!isdigit (str[k]))
14f9c5c9
AS
6527 return 0;
6528
4c4b4cd2 6529 /* Do it the hard way so as not to make any assumption about
14f9c5c9 6530 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 6531 LONGEST. */
14f9c5c9
AS
6532 RU = 0;
6533 while (isdigit (str[k]))
6534 {
d2e4a39e 6535 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
6536 k += 1;
6537 }
6538
d2e4a39e 6539 if (str[k] == 'm')
14f9c5c9
AS
6540 {
6541 if (R != NULL)
4c4b4cd2 6542 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
6543 k += 1;
6544 }
6545 else if (R != NULL)
6546 *R = (LONGEST) RU;
6547
4c4b4cd2 6548 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
6549 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6550 number representable as a LONGEST (although either would probably work
6551 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 6552 above is always equivalent to the negative of RU. */
14f9c5c9
AS
6553
6554 if (new_k != NULL)
6555 *new_k = k;
6556 return 1;
6557}
6558
4c4b4cd2
PH
6559/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6560 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6561 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 6562
d2e4a39e 6563int
ebf56fd3 6564ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 6565{
d2e4a39e 6566 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
6567 int p;
6568
6569 p = 0;
6570 while (1)
6571 {
d2e4a39e 6572 switch (name[p])
4c4b4cd2
PH
6573 {
6574 case '\0':
6575 return 0;
6576 case 'S':
6577 {
6578 LONGEST W;
5b4ee69b 6579
4c4b4cd2
PH
6580 if (!ada_scan_number (name, p + 1, &W, &p))
6581 return 0;
6582 if (val == W)
6583 return 1;
6584 break;
6585 }
6586 case 'R':
6587 {
6588 LONGEST L, U;
5b4ee69b 6589
4c4b4cd2
PH
6590 if (!ada_scan_number (name, p + 1, &L, &p)
6591 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6592 return 0;
6593 if (val >= L && val <= U)
6594 return 1;
6595 break;
6596 }
6597 case 'O':
6598 return 1;
6599 default:
6600 return 0;
6601 }
6602 }
6603}
6604
0963b4bd 6605/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
6606
6607/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6608 ARG_TYPE, extract and return the value of one of its (non-static)
6609 fields. FIELDNO says which field. Differs from value_primitive_field
6610 only in that it can handle packed values of arbitrary type. */
14f9c5c9 6611
4c4b4cd2 6612static struct value *
d2e4a39e 6613ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 6614 struct type *arg_type)
14f9c5c9 6615{
14f9c5c9
AS
6616 struct type *type;
6617
61ee279c 6618 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
6619 type = TYPE_FIELD_TYPE (arg_type, fieldno);
6620
4c4b4cd2 6621 /* Handle packed fields. */
14f9c5c9
AS
6622
6623 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
6624 {
6625 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6626 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 6627
0fd88904 6628 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
6629 offset + bit_pos / 8,
6630 bit_pos % 8, bit_size, type);
14f9c5c9
AS
6631 }
6632 else
6633 return value_primitive_field (arg1, offset, fieldno, arg_type);
6634}
6635
52ce6436
PH
6636/* Find field with name NAME in object of type TYPE. If found,
6637 set the following for each argument that is non-null:
6638 - *FIELD_TYPE_P to the field's type;
6639 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6640 an object of that type;
6641 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6642 - *BIT_SIZE_P to its size in bits if the field is packed, and
6643 0 otherwise;
6644 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6645 fields up to but not including the desired field, or by the total
6646 number of fields if not found. A NULL value of NAME never
6647 matches; the function just counts visible fields in this case.
6648
0963b4bd 6649 Returns 1 if found, 0 otherwise. */
52ce6436 6650
4c4b4cd2 6651static int
0d5cff50 6652find_struct_field (const char *name, struct type *type, int offset,
76a01679 6653 struct type **field_type_p,
52ce6436
PH
6654 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6655 int *index_p)
4c4b4cd2
PH
6656{
6657 int i;
6658
61ee279c 6659 type = ada_check_typedef (type);
76a01679 6660
52ce6436
PH
6661 if (field_type_p != NULL)
6662 *field_type_p = NULL;
6663 if (byte_offset_p != NULL)
d5d6fca5 6664 *byte_offset_p = 0;
52ce6436
PH
6665 if (bit_offset_p != NULL)
6666 *bit_offset_p = 0;
6667 if (bit_size_p != NULL)
6668 *bit_size_p = 0;
6669
6670 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
6671 {
6672 int bit_pos = TYPE_FIELD_BITPOS (type, i);
6673 int fld_offset = offset + bit_pos / 8;
0d5cff50 6674 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 6675
4c4b4cd2
PH
6676 if (t_field_name == NULL)
6677 continue;
6678
52ce6436 6679 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
6680 {
6681 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 6682
52ce6436
PH
6683 if (field_type_p != NULL)
6684 *field_type_p = TYPE_FIELD_TYPE (type, i);
6685 if (byte_offset_p != NULL)
6686 *byte_offset_p = fld_offset;
6687 if (bit_offset_p != NULL)
6688 *bit_offset_p = bit_pos % 8;
6689 if (bit_size_p != NULL)
6690 *bit_size_p = bit_size;
76a01679
JB
6691 return 1;
6692 }
4c4b4cd2
PH
6693 else if (ada_is_wrapper_field (type, i))
6694 {
52ce6436
PH
6695 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
6696 field_type_p, byte_offset_p, bit_offset_p,
6697 bit_size_p, index_p))
76a01679
JB
6698 return 1;
6699 }
4c4b4cd2
PH
6700 else if (ada_is_variant_part (type, i))
6701 {
52ce6436
PH
6702 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6703 fixed type?? */
4c4b4cd2 6704 int j;
52ce6436
PH
6705 struct type *field_type
6706 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 6707
52ce6436 6708 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6709 {
76a01679
JB
6710 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
6711 fld_offset
6712 + TYPE_FIELD_BITPOS (field_type, j) / 8,
6713 field_type_p, byte_offset_p,
52ce6436 6714 bit_offset_p, bit_size_p, index_p))
76a01679 6715 return 1;
4c4b4cd2
PH
6716 }
6717 }
52ce6436
PH
6718 else if (index_p != NULL)
6719 *index_p += 1;
4c4b4cd2
PH
6720 }
6721 return 0;
6722}
6723
0963b4bd 6724/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 6725
52ce6436
PH
6726static int
6727num_visible_fields (struct type *type)
6728{
6729 int n;
5b4ee69b 6730
52ce6436
PH
6731 n = 0;
6732 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6733 return n;
6734}
14f9c5c9 6735
4c4b4cd2 6736/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
6737 and search in it assuming it has (class) type TYPE.
6738 If found, return value, else return NULL.
6739
4c4b4cd2 6740 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 6741
4c4b4cd2 6742static struct value *
d2e4a39e 6743ada_search_struct_field (char *name, struct value *arg, int offset,
4c4b4cd2 6744 struct type *type)
14f9c5c9
AS
6745{
6746 int i;
14f9c5c9 6747
5b4ee69b 6748 type = ada_check_typedef (type);
52ce6436 6749 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 6750 {
0d5cff50 6751 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
6752
6753 if (t_field_name == NULL)
4c4b4cd2 6754 continue;
14f9c5c9
AS
6755
6756 else if (field_name_match (t_field_name, name))
4c4b4cd2 6757 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
6758
6759 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 6760 {
0963b4bd 6761 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
6762 ada_search_struct_field (name, arg,
6763 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6764 TYPE_FIELD_TYPE (type, i));
5b4ee69b 6765
4c4b4cd2
PH
6766 if (v != NULL)
6767 return v;
6768 }
14f9c5c9
AS
6769
6770 else if (ada_is_variant_part (type, i))
4c4b4cd2 6771 {
0963b4bd 6772 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 6773 int j;
5b4ee69b
MS
6774 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
6775 i));
4c4b4cd2
PH
6776 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6777
52ce6436 6778 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6779 {
0963b4bd
MS
6780 struct value *v = ada_search_struct_field /* Force line
6781 break. */
06d5cf63
JB
6782 (name, arg,
6783 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6784 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 6785
4c4b4cd2
PH
6786 if (v != NULL)
6787 return v;
6788 }
6789 }
14f9c5c9
AS
6790 }
6791 return NULL;
6792}
d2e4a39e 6793
52ce6436
PH
6794static struct value *ada_index_struct_field_1 (int *, struct value *,
6795 int, struct type *);
6796
6797
6798/* Return field #INDEX in ARG, where the index is that returned by
6799 * find_struct_field through its INDEX_P argument. Adjust the address
6800 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 6801 * If found, return value, else return NULL. */
52ce6436
PH
6802
6803static struct value *
6804ada_index_struct_field (int index, struct value *arg, int offset,
6805 struct type *type)
6806{
6807 return ada_index_struct_field_1 (&index, arg, offset, type);
6808}
6809
6810
6811/* Auxiliary function for ada_index_struct_field. Like
6812 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 6813 * *INDEX_P. */
52ce6436
PH
6814
6815static struct value *
6816ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6817 struct type *type)
6818{
6819 int i;
6820 type = ada_check_typedef (type);
6821
6822 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6823 {
6824 if (TYPE_FIELD_NAME (type, i) == NULL)
6825 continue;
6826 else if (ada_is_wrapper_field (type, i))
6827 {
0963b4bd 6828 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
6829 ada_index_struct_field_1 (index_p, arg,
6830 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6831 TYPE_FIELD_TYPE (type, i));
5b4ee69b 6832
52ce6436
PH
6833 if (v != NULL)
6834 return v;
6835 }
6836
6837 else if (ada_is_variant_part (type, i))
6838 {
6839 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 6840 find_struct_field. */
52ce6436
PH
6841 error (_("Cannot assign this kind of variant record"));
6842 }
6843 else if (*index_p == 0)
6844 return ada_value_primitive_field (arg, offset, i, type);
6845 else
6846 *index_p -= 1;
6847 }
6848 return NULL;
6849}
6850
4c4b4cd2
PH
6851/* Given ARG, a value of type (pointer or reference to a)*
6852 structure/union, extract the component named NAME from the ultimate
6853 target structure/union and return it as a value with its
f5938064 6854 appropriate type.
14f9c5c9 6855
4c4b4cd2
PH
6856 The routine searches for NAME among all members of the structure itself
6857 and (recursively) among all members of any wrapper members
14f9c5c9
AS
6858 (e.g., '_parent').
6859
03ee6b2e
PH
6860 If NO_ERR, then simply return NULL in case of error, rather than
6861 calling error. */
14f9c5c9 6862
d2e4a39e 6863struct value *
03ee6b2e 6864ada_value_struct_elt (struct value *arg, char *name, int no_err)
14f9c5c9 6865{
4c4b4cd2 6866 struct type *t, *t1;
d2e4a39e 6867 struct value *v;
14f9c5c9 6868
4c4b4cd2 6869 v = NULL;
df407dfe 6870 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
6871 if (TYPE_CODE (t) == TYPE_CODE_REF)
6872 {
6873 t1 = TYPE_TARGET_TYPE (t);
6874 if (t1 == NULL)
03ee6b2e 6875 goto BadValue;
61ee279c 6876 t1 = ada_check_typedef (t1);
4c4b4cd2 6877 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 6878 {
994b9211 6879 arg = coerce_ref (arg);
76a01679
JB
6880 t = t1;
6881 }
4c4b4cd2 6882 }
14f9c5c9 6883
4c4b4cd2
PH
6884 while (TYPE_CODE (t) == TYPE_CODE_PTR)
6885 {
6886 t1 = TYPE_TARGET_TYPE (t);
6887 if (t1 == NULL)
03ee6b2e 6888 goto BadValue;
61ee279c 6889 t1 = ada_check_typedef (t1);
4c4b4cd2 6890 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
6891 {
6892 arg = value_ind (arg);
6893 t = t1;
6894 }
4c4b4cd2 6895 else
76a01679 6896 break;
4c4b4cd2 6897 }
14f9c5c9 6898
4c4b4cd2 6899 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 6900 goto BadValue;
14f9c5c9 6901
4c4b4cd2
PH
6902 if (t1 == t)
6903 v = ada_search_struct_field (name, arg, 0, t);
6904 else
6905 {
6906 int bit_offset, bit_size, byte_offset;
6907 struct type *field_type;
6908 CORE_ADDR address;
6909
76a01679 6910 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 6911 address = value_address (ada_value_ind (arg));
4c4b4cd2 6912 else
b50d69b5 6913 address = value_address (ada_coerce_ref (arg));
14f9c5c9 6914
1ed6ede0 6915 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
76a01679
JB
6916 if (find_struct_field (name, t1, 0,
6917 &field_type, &byte_offset, &bit_offset,
52ce6436 6918 &bit_size, NULL))
76a01679
JB
6919 {
6920 if (bit_size != 0)
6921 {
714e53ab
PH
6922 if (TYPE_CODE (t) == TYPE_CODE_REF)
6923 arg = ada_coerce_ref (arg);
6924 else
6925 arg = ada_value_ind (arg);
76a01679
JB
6926 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
6927 bit_offset, bit_size,
6928 field_type);
6929 }
6930 else
f5938064 6931 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
6932 }
6933 }
6934
03ee6b2e
PH
6935 if (v != NULL || no_err)
6936 return v;
6937 else
323e0a4a 6938 error (_("There is no member named %s."), name);
14f9c5c9 6939
03ee6b2e
PH
6940 BadValue:
6941 if (no_err)
6942 return NULL;
6943 else
0963b4bd
MS
6944 error (_("Attempt to extract a component of "
6945 "a value that is not a record."));
14f9c5c9
AS
6946}
6947
6948/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
6949 If DISPP is non-null, add its byte displacement from the beginning of a
6950 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
6951 work for packed fields).
6952
6953 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 6954 followed by "___".
14f9c5c9 6955
0963b4bd 6956 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
6957 be a (pointer or reference)+ to a struct or union, and the
6958 ultimate target type will be searched.
14f9c5c9
AS
6959
6960 Looks recursively into variant clauses and parent types.
6961
4c4b4cd2
PH
6962 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6963 TYPE is not a type of the right kind. */
14f9c5c9 6964
4c4b4cd2 6965static struct type *
76a01679
JB
6966ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
6967 int noerr, int *dispp)
14f9c5c9
AS
6968{
6969 int i;
6970
6971 if (name == NULL)
6972 goto BadName;
6973
76a01679 6974 if (refok && type != NULL)
4c4b4cd2
PH
6975 while (1)
6976 {
61ee279c 6977 type = ada_check_typedef (type);
76a01679
JB
6978 if (TYPE_CODE (type) != TYPE_CODE_PTR
6979 && TYPE_CODE (type) != TYPE_CODE_REF)
6980 break;
6981 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 6982 }
14f9c5c9 6983
76a01679 6984 if (type == NULL
1265e4aa
JB
6985 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
6986 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 6987 {
4c4b4cd2 6988 if (noerr)
76a01679 6989 return NULL;
4c4b4cd2 6990 else
76a01679
JB
6991 {
6992 target_terminal_ours ();
6993 gdb_flush (gdb_stdout);
323e0a4a
AC
6994 if (type == NULL)
6995 error (_("Type (null) is not a structure or union type"));
6996 else
6997 {
6998 /* XXX: type_sprint */
6999 fprintf_unfiltered (gdb_stderr, _("Type "));
7000 type_print (type, "", gdb_stderr, -1);
7001 error (_(" is not a structure or union type"));
7002 }
76a01679 7003 }
14f9c5c9
AS
7004 }
7005
7006 type = to_static_fixed_type (type);
7007
7008 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7009 {
0d5cff50 7010 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7011 struct type *t;
7012 int disp;
d2e4a39e 7013
14f9c5c9 7014 if (t_field_name == NULL)
4c4b4cd2 7015 continue;
14f9c5c9
AS
7016
7017 else if (field_name_match (t_field_name, name))
4c4b4cd2
PH
7018 {
7019 if (dispp != NULL)
7020 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
61ee279c 7021 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7022 }
14f9c5c9
AS
7023
7024 else if (ada_is_wrapper_field (type, i))
4c4b4cd2
PH
7025 {
7026 disp = 0;
7027 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7028 0, 1, &disp);
7029 if (t != NULL)
7030 {
7031 if (dispp != NULL)
7032 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7033 return t;
7034 }
7035 }
14f9c5c9
AS
7036
7037 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7038 {
7039 int j;
5b4ee69b
MS
7040 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7041 i));
4c4b4cd2
PH
7042
7043 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7044 {
b1f33ddd
JB
7045 /* FIXME pnh 2008/01/26: We check for a field that is
7046 NOT wrapped in a struct, since the compiler sometimes
7047 generates these for unchecked variant types. Revisit
0963b4bd 7048 if the compiler changes this practice. */
0d5cff50 7049 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
4c4b4cd2 7050 disp = 0;
b1f33ddd
JB
7051 if (v_field_name != NULL
7052 && field_name_match (v_field_name, name))
7053 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
7054 else
0963b4bd
MS
7055 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7056 j),
b1f33ddd
JB
7057 name, 0, 1, &disp);
7058
4c4b4cd2
PH
7059 if (t != NULL)
7060 {
7061 if (dispp != NULL)
7062 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7063 return t;
7064 }
7065 }
7066 }
14f9c5c9
AS
7067
7068 }
7069
7070BadName:
d2e4a39e 7071 if (!noerr)
14f9c5c9
AS
7072 {
7073 target_terminal_ours ();
7074 gdb_flush (gdb_stdout);
323e0a4a
AC
7075 if (name == NULL)
7076 {
7077 /* XXX: type_sprint */
7078 fprintf_unfiltered (gdb_stderr, _("Type "));
7079 type_print (type, "", gdb_stderr, -1);
7080 error (_(" has no component named <null>"));
7081 }
7082 else
7083 {
7084 /* XXX: type_sprint */
7085 fprintf_unfiltered (gdb_stderr, _("Type "));
7086 type_print (type, "", gdb_stderr, -1);
7087 error (_(" has no component named %s"), name);
7088 }
14f9c5c9
AS
7089 }
7090
7091 return NULL;
7092}
7093
b1f33ddd
JB
7094/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7095 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7096 represents an unchecked union (that is, the variant part of a
0963b4bd 7097 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7098
7099static int
7100is_unchecked_variant (struct type *var_type, struct type *outer_type)
7101{
7102 char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7103
b1f33ddd
JB
7104 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
7105 == NULL);
7106}
7107
7108
14f9c5c9
AS
7109/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7110 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7111 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7112 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7113
d2e4a39e 7114int
ebf56fd3 7115ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7116 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7117{
7118 int others_clause;
7119 int i;
d2e4a39e 7120 char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7121 struct value *outer;
7122 struct value *discrim;
14f9c5c9
AS
7123 LONGEST discrim_val;
7124
0c281816
JB
7125 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
7126 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7127 if (discrim == NULL)
14f9c5c9 7128 return -1;
0c281816 7129 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7130
7131 others_clause = -1;
7132 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7133 {
7134 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7135 others_clause = i;
14f9c5c9 7136 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7137 return i;
14f9c5c9
AS
7138 }
7139
7140 return others_clause;
7141}
d2e4a39e 7142\f
14f9c5c9
AS
7143
7144
4c4b4cd2 7145 /* Dynamic-Sized Records */
14f9c5c9
AS
7146
7147/* Strategy: The type ostensibly attached to a value with dynamic size
7148 (i.e., a size that is not statically recorded in the debugging
7149 data) does not accurately reflect the size or layout of the value.
7150 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7151 conventional types that are constructed on the fly. */
14f9c5c9
AS
7152
7153/* There is a subtle and tricky problem here. In general, we cannot
7154 determine the size of dynamic records without its data. However,
7155 the 'struct value' data structure, which GDB uses to represent
7156 quantities in the inferior process (the target), requires the size
7157 of the type at the time of its allocation in order to reserve space
7158 for GDB's internal copy of the data. That's why the
7159 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7160 rather than struct value*s.
14f9c5c9
AS
7161
7162 However, GDB's internal history variables ($1, $2, etc.) are
7163 struct value*s containing internal copies of the data that are not, in
7164 general, the same as the data at their corresponding addresses in
7165 the target. Fortunately, the types we give to these values are all
7166 conventional, fixed-size types (as per the strategy described
7167 above), so that we don't usually have to perform the
7168 'to_fixed_xxx_type' conversions to look at their values.
7169 Unfortunately, there is one exception: if one of the internal
7170 history variables is an array whose elements are unconstrained
7171 records, then we will need to create distinct fixed types for each
7172 element selected. */
7173
7174/* The upshot of all of this is that many routines take a (type, host
7175 address, target address) triple as arguments to represent a value.
7176 The host address, if non-null, is supposed to contain an internal
7177 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7178 target at the target address. */
14f9c5c9
AS
7179
7180/* Assuming that VAL0 represents a pointer value, the result of
7181 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7182 dynamic-sized types. */
14f9c5c9 7183
d2e4a39e
AS
7184struct value *
7185ada_value_ind (struct value *val0)
14f9c5c9 7186{
c48db5ca 7187 struct value *val = value_ind (val0);
5b4ee69b 7188
b50d69b5
JG
7189 if (ada_is_tagged_type (value_type (val), 0))
7190 val = ada_tag_value_at_base_address (val);
7191
4c4b4cd2 7192 return ada_to_fixed_value (val);
14f9c5c9
AS
7193}
7194
7195/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7196 qualifiers on VAL0. */
7197
d2e4a39e
AS
7198static struct value *
7199ada_coerce_ref (struct value *val0)
7200{
df407dfe 7201 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7202 {
7203 struct value *val = val0;
5b4ee69b 7204
994b9211 7205 val = coerce_ref (val);
b50d69b5
JG
7206
7207 if (ada_is_tagged_type (value_type (val), 0))
7208 val = ada_tag_value_at_base_address (val);
7209
4c4b4cd2 7210 return ada_to_fixed_value (val);
d2e4a39e
AS
7211 }
7212 else
14f9c5c9
AS
7213 return val0;
7214}
7215
7216/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7217 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7218
7219static unsigned int
ebf56fd3 7220align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7221{
7222 return (off + alignment - 1) & ~(alignment - 1);
7223}
7224
4c4b4cd2 7225/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7226
7227static unsigned int
ebf56fd3 7228field_alignment (struct type *type, int f)
14f9c5c9 7229{
d2e4a39e 7230 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7231 int len;
14f9c5c9
AS
7232 int align_offset;
7233
64a1bf19
JB
7234 /* The field name should never be null, unless the debugging information
7235 is somehow malformed. In this case, we assume the field does not
7236 require any alignment. */
7237 if (name == NULL)
7238 return 1;
7239
7240 len = strlen (name);
7241
4c4b4cd2
PH
7242 if (!isdigit (name[len - 1]))
7243 return 1;
14f9c5c9 7244
d2e4a39e 7245 if (isdigit (name[len - 2]))
14f9c5c9
AS
7246 align_offset = len - 2;
7247 else
7248 align_offset = len - 1;
7249
4c4b4cd2 7250 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
14f9c5c9
AS
7251 return TARGET_CHAR_BIT;
7252
4c4b4cd2
PH
7253 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7254}
7255
852dff6c 7256/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7257
852dff6c
JB
7258static struct symbol *
7259ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7260{
7261 struct symbol *sym;
7262
7263 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7264 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7265 return sym;
7266
7267 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7268 return sym;
14f9c5c9
AS
7269}
7270
dddfab26
UW
7271/* Find a type named NAME. Ignores ambiguity. This routine will look
7272 solely for types defined by debug info, it will not search the GDB
7273 primitive types. */
4c4b4cd2 7274
852dff6c 7275static struct type *
ebf56fd3 7276ada_find_any_type (const char *name)
14f9c5c9 7277{
852dff6c 7278 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7279
14f9c5c9 7280 if (sym != NULL)
dddfab26 7281 return SYMBOL_TYPE (sym);
14f9c5c9 7282
dddfab26 7283 return NULL;
14f9c5c9
AS
7284}
7285
739593e0
JB
7286/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7287 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7288 symbol, in which case it is returned. Otherwise, this looks for
7289 symbols whose name is that of NAME_SYM suffixed with "___XR".
7290 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7291
7292struct symbol *
270140bd 7293ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7294{
739593e0 7295 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7296 struct symbol *sym;
7297
739593e0
JB
7298 if (strstr (name, "___XR") != NULL)
7299 return name_sym;
7300
aeb5907d
JB
7301 sym = find_old_style_renaming_symbol (name, block);
7302
7303 if (sym != NULL)
7304 return sym;
7305
0963b4bd 7306 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7307 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7308 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7309 return sym;
7310 else
7311 return NULL;
7312}
7313
7314static struct symbol *
270140bd 7315find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 7316{
7f0df278 7317 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
7318 char *rename;
7319
7320 if (function_sym != NULL)
7321 {
7322 /* If the symbol is defined inside a function, NAME is not fully
7323 qualified. This means we need to prepend the function name
7324 as well as adding the ``___XR'' suffix to build the name of
7325 the associated renaming symbol. */
0d5cff50 7326 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
7327 /* Function names sometimes contain suffixes used
7328 for instance to qualify nested subprograms. When building
7329 the XR type name, we need to make sure that this suffix is
7330 not included. So do not include any suffix in the function
7331 name length below. */
69fadcdf 7332 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
7333 const int rename_len = function_name_len + 2 /* "__" */
7334 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 7335
529cad9c 7336 /* Strip the suffix if necessary. */
69fadcdf
JB
7337 ada_remove_trailing_digits (function_name, &function_name_len);
7338 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7339 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 7340
4c4b4cd2
PH
7341 /* Library-level functions are a special case, as GNAT adds
7342 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 7343 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
7344 have this prefix, so we need to skip this prefix if present. */
7345 if (function_name_len > 5 /* "_ada_" */
7346 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
7347 {
7348 function_name += 5;
7349 function_name_len -= 5;
7350 }
4c4b4cd2
PH
7351
7352 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
7353 strncpy (rename, function_name, function_name_len);
7354 xsnprintf (rename + function_name_len, rename_len - function_name_len,
7355 "__%s___XR", name);
4c4b4cd2
PH
7356 }
7357 else
7358 {
7359 const int rename_len = strlen (name) + 6;
5b4ee69b 7360
4c4b4cd2 7361 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 7362 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
7363 }
7364
852dff6c 7365 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
7366}
7367
14f9c5c9 7368/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 7369 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 7370 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
7371 otherwise return 0. */
7372
14f9c5c9 7373int
d2e4a39e 7374ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
7375{
7376 if (type1 == NULL)
7377 return 1;
7378 else if (type0 == NULL)
7379 return 0;
7380 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7381 return 1;
7382 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7383 return 0;
4c4b4cd2
PH
7384 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7385 return 1;
ad82864c 7386 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 7387 return 1;
4c4b4cd2
PH
7388 else if (ada_is_array_descriptor_type (type0)
7389 && !ada_is_array_descriptor_type (type1))
14f9c5c9 7390 return 1;
aeb5907d
JB
7391 else
7392 {
7393 const char *type0_name = type_name_no_tag (type0);
7394 const char *type1_name = type_name_no_tag (type1);
7395
7396 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7397 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7398 return 1;
7399 }
14f9c5c9
AS
7400 return 0;
7401}
7402
7403/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
7404 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7405
0d5cff50 7406const char *
d2e4a39e 7407ada_type_name (struct type *type)
14f9c5c9 7408{
d2e4a39e 7409 if (type == NULL)
14f9c5c9
AS
7410 return NULL;
7411 else if (TYPE_NAME (type) != NULL)
7412 return TYPE_NAME (type);
7413 else
7414 return TYPE_TAG_NAME (type);
7415}
7416
b4ba55a1
JB
7417/* Search the list of "descriptive" types associated to TYPE for a type
7418 whose name is NAME. */
7419
7420static struct type *
7421find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7422{
7423 struct type *result;
7424
7425 /* If there no descriptive-type info, then there is no parallel type
7426 to be found. */
7427 if (!HAVE_GNAT_AUX_INFO (type))
7428 return NULL;
7429
7430 result = TYPE_DESCRIPTIVE_TYPE (type);
7431 while (result != NULL)
7432 {
0d5cff50 7433 const char *result_name = ada_type_name (result);
b4ba55a1
JB
7434
7435 if (result_name == NULL)
7436 {
7437 warning (_("unexpected null name on descriptive type"));
7438 return NULL;
7439 }
7440
7441 /* If the names match, stop. */
7442 if (strcmp (result_name, name) == 0)
7443 break;
7444
7445 /* Otherwise, look at the next item on the list, if any. */
7446 if (HAVE_GNAT_AUX_INFO (result))
7447 result = TYPE_DESCRIPTIVE_TYPE (result);
7448 else
7449 result = NULL;
7450 }
7451
7452 /* If we didn't find a match, see whether this is a packed array. With
7453 older compilers, the descriptive type information is either absent or
7454 irrelevant when it comes to packed arrays so the above lookup fails.
7455 Fall back to using a parallel lookup by name in this case. */
12ab9e09 7456 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
7457 return ada_find_any_type (name);
7458
7459 return result;
7460}
7461
7462/* Find a parallel type to TYPE with the specified NAME, using the
7463 descriptive type taken from the debugging information, if available,
7464 and otherwise using the (slower) name-based method. */
7465
7466static struct type *
7467ada_find_parallel_type_with_name (struct type *type, const char *name)
7468{
7469 struct type *result = NULL;
7470
7471 if (HAVE_GNAT_AUX_INFO (type))
7472 result = find_parallel_type_by_descriptive_type (type, name);
7473 else
7474 result = ada_find_any_type (name);
7475
7476 return result;
7477}
7478
7479/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 7480 SUFFIX to the name of TYPE. */
14f9c5c9 7481
d2e4a39e 7482struct type *
ebf56fd3 7483ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 7484{
0d5cff50
DE
7485 char *name;
7486 const char *typename = ada_type_name (type);
14f9c5c9 7487 int len;
d2e4a39e 7488
14f9c5c9
AS
7489 if (typename == NULL)
7490 return NULL;
7491
7492 len = strlen (typename);
7493
b4ba55a1 7494 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9
AS
7495
7496 strcpy (name, typename);
7497 strcpy (name + len, suffix);
7498
b4ba55a1 7499 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
7500}
7501
14f9c5c9 7502/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 7503 type describing its fields. Otherwise, return NULL. */
14f9c5c9 7504
d2e4a39e
AS
7505static struct type *
7506dynamic_template_type (struct type *type)
14f9c5c9 7507{
61ee279c 7508 type = ada_check_typedef (type);
14f9c5c9
AS
7509
7510 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 7511 || ada_type_name (type) == NULL)
14f9c5c9 7512 return NULL;
d2e4a39e 7513 else
14f9c5c9
AS
7514 {
7515 int len = strlen (ada_type_name (type));
5b4ee69b 7516
4c4b4cd2
PH
7517 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7518 return type;
14f9c5c9 7519 else
4c4b4cd2 7520 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
7521 }
7522}
7523
7524/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 7525 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 7526
d2e4a39e
AS
7527static int
7528is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
7529{
7530 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 7531
d2e4a39e 7532 return name != NULL
14f9c5c9
AS
7533 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
7534 && strstr (name, "___XVL") != NULL;
7535}
7536
4c4b4cd2
PH
7537/* The index of the variant field of TYPE, or -1 if TYPE does not
7538 represent a variant record type. */
14f9c5c9 7539
d2e4a39e 7540static int
4c4b4cd2 7541variant_field_index (struct type *type)
14f9c5c9
AS
7542{
7543 int f;
7544
4c4b4cd2
PH
7545 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
7546 return -1;
7547
7548 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
7549 {
7550 if (ada_is_variant_part (type, f))
7551 return f;
7552 }
7553 return -1;
14f9c5c9
AS
7554}
7555
4c4b4cd2
PH
7556/* A record type with no fields. */
7557
d2e4a39e 7558static struct type *
e9bb382b 7559empty_record (struct type *template)
14f9c5c9 7560{
e9bb382b 7561 struct type *type = alloc_type_copy (template);
5b4ee69b 7562
14f9c5c9
AS
7563 TYPE_CODE (type) = TYPE_CODE_STRUCT;
7564 TYPE_NFIELDS (type) = 0;
7565 TYPE_FIELDS (type) = NULL;
b1f33ddd 7566 INIT_CPLUS_SPECIFIC (type);
14f9c5c9
AS
7567 TYPE_NAME (type) = "<empty>";
7568 TYPE_TAG_NAME (type) = NULL;
14f9c5c9
AS
7569 TYPE_LENGTH (type) = 0;
7570 return type;
7571}
7572
7573/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
7574 the value of type TYPE at VALADDR or ADDRESS (see comments at
7575 the beginning of this section) VAL according to GNAT conventions.
7576 DVAL0 should describe the (portion of a) record that contains any
df407dfe 7577 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
7578 an outer-level type (i.e., as opposed to a branch of a variant.) A
7579 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 7580 of the variant.
14f9c5c9 7581
4c4b4cd2
PH
7582 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7583 length are not statically known are discarded. As a consequence,
7584 VALADDR, ADDRESS and DVAL0 are ignored.
7585
7586 NOTE: Limitations: For now, we assume that dynamic fields and
7587 variants occupy whole numbers of bytes. However, they need not be
7588 byte-aligned. */
7589
7590struct type *
10a2c479 7591ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 7592 const gdb_byte *valaddr,
4c4b4cd2
PH
7593 CORE_ADDR address, struct value *dval0,
7594 int keep_dynamic_fields)
14f9c5c9 7595{
d2e4a39e
AS
7596 struct value *mark = value_mark ();
7597 struct value *dval;
7598 struct type *rtype;
14f9c5c9 7599 int nfields, bit_len;
4c4b4cd2 7600 int variant_field;
14f9c5c9 7601 long off;
d94e4f4f 7602 int fld_bit_len;
14f9c5c9
AS
7603 int f;
7604
4c4b4cd2
PH
7605 /* Compute the number of fields in this record type that are going
7606 to be processed: unless keep_dynamic_fields, this includes only
7607 fields whose position and length are static will be processed. */
7608 if (keep_dynamic_fields)
7609 nfields = TYPE_NFIELDS (type);
7610 else
7611 {
7612 nfields = 0;
76a01679 7613 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
7614 && !ada_is_variant_part (type, nfields)
7615 && !is_dynamic_field (type, nfields))
7616 nfields++;
7617 }
7618
e9bb382b 7619 rtype = alloc_type_copy (type);
14f9c5c9
AS
7620 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7621 INIT_CPLUS_SPECIFIC (rtype);
7622 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 7623 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
7624 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7625 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
7626 TYPE_NAME (rtype) = ada_type_name (type);
7627 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7628 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 7629
d2e4a39e
AS
7630 off = 0;
7631 bit_len = 0;
4c4b4cd2
PH
7632 variant_field = -1;
7633
14f9c5c9
AS
7634 for (f = 0; f < nfields; f += 1)
7635 {
6c038f32
PH
7636 off = align_value (off, field_alignment (type, f))
7637 + TYPE_FIELD_BITPOS (type, f);
945b3a32 7638 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 7639 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 7640
d2e4a39e 7641 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
7642 {
7643 variant_field = f;
d94e4f4f 7644 fld_bit_len = 0;
4c4b4cd2 7645 }
14f9c5c9 7646 else if (is_dynamic_field (type, f))
4c4b4cd2 7647 {
284614f0
JB
7648 const gdb_byte *field_valaddr = valaddr;
7649 CORE_ADDR field_address = address;
7650 struct type *field_type =
7651 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
7652
4c4b4cd2 7653 if (dval0 == NULL)
b5304971
JG
7654 {
7655 /* rtype's length is computed based on the run-time
7656 value of discriminants. If the discriminants are not
7657 initialized, the type size may be completely bogus and
0963b4bd 7658 GDB may fail to allocate a value for it. So check the
b5304971
JG
7659 size first before creating the value. */
7660 check_size (rtype);
7661 dval = value_from_contents_and_address (rtype, valaddr, address);
7662 }
4c4b4cd2
PH
7663 else
7664 dval = dval0;
7665
284614f0
JB
7666 /* If the type referenced by this field is an aligner type, we need
7667 to unwrap that aligner type, because its size might not be set.
7668 Keeping the aligner type would cause us to compute the wrong
7669 size for this field, impacting the offset of the all the fields
7670 that follow this one. */
7671 if (ada_is_aligner_type (field_type))
7672 {
7673 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
7674
7675 field_valaddr = cond_offset_host (field_valaddr, field_offset);
7676 field_address = cond_offset_target (field_address, field_offset);
7677 field_type = ada_aligned_type (field_type);
7678 }
7679
7680 field_valaddr = cond_offset_host (field_valaddr,
7681 off / TARGET_CHAR_BIT);
7682 field_address = cond_offset_target (field_address,
7683 off / TARGET_CHAR_BIT);
7684
7685 /* Get the fixed type of the field. Note that, in this case,
7686 we do not want to get the real type out of the tag: if
7687 the current field is the parent part of a tagged record,
7688 we will get the tag of the object. Clearly wrong: the real
7689 type of the parent is not the real type of the child. We
7690 would end up in an infinite loop. */
7691 field_type = ada_get_base_type (field_type);
7692 field_type = ada_to_fixed_type (field_type, field_valaddr,
7693 field_address, dval, 0);
27f2a97b
JB
7694 /* If the field size is already larger than the maximum
7695 object size, then the record itself will necessarily
7696 be larger than the maximum object size. We need to make
7697 this check now, because the size might be so ridiculously
7698 large (due to an uninitialized variable in the inferior)
7699 that it would cause an overflow when adding it to the
7700 record size. */
7701 check_size (field_type);
284614f0
JB
7702
7703 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 7704 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
7705 /* The multiplication can potentially overflow. But because
7706 the field length has been size-checked just above, and
7707 assuming that the maximum size is a reasonable value,
7708 an overflow should not happen in practice. So rather than
7709 adding overflow recovery code to this already complex code,
7710 we just assume that it's not going to happen. */
d94e4f4f 7711 fld_bit_len =
4c4b4cd2
PH
7712 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
7713 }
14f9c5c9 7714 else
4c4b4cd2 7715 {
5ded5331
JB
7716 /* Note: If this field's type is a typedef, it is important
7717 to preserve the typedef layer.
7718
7719 Otherwise, we might be transforming a typedef to a fat
7720 pointer (encoding a pointer to an unconstrained array),
7721 into a basic fat pointer (encoding an unconstrained
7722 array). As both types are implemented using the same
7723 structure, the typedef is the only clue which allows us
7724 to distinguish between the two options. Stripping it
7725 would prevent us from printing this field appropriately. */
7726 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
7727 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7728 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 7729 fld_bit_len =
4c4b4cd2
PH
7730 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7731 else
5ded5331
JB
7732 {
7733 struct type *field_type = TYPE_FIELD_TYPE (type, f);
7734
7735 /* We need to be careful of typedefs when computing
7736 the length of our field. If this is a typedef,
7737 get the length of the target type, not the length
7738 of the typedef. */
7739 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
7740 field_type = ada_typedef_target_type (field_type);
7741
7742 fld_bit_len =
7743 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7744 }
4c4b4cd2 7745 }
14f9c5c9 7746 if (off + fld_bit_len > bit_len)
4c4b4cd2 7747 bit_len = off + fld_bit_len;
d94e4f4f 7748 off += fld_bit_len;
4c4b4cd2
PH
7749 TYPE_LENGTH (rtype) =
7750 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 7751 }
4c4b4cd2
PH
7752
7753 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 7754 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
7755 the record. This can happen in the presence of representation
7756 clauses. */
7757 if (variant_field >= 0)
7758 {
7759 struct type *branch_type;
7760
7761 off = TYPE_FIELD_BITPOS (rtype, variant_field);
7762
7763 if (dval0 == NULL)
7764 dval = value_from_contents_and_address (rtype, valaddr, address);
7765 else
7766 dval = dval0;
7767
7768 branch_type =
7769 to_fixed_variant_branch_type
7770 (TYPE_FIELD_TYPE (type, variant_field),
7771 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7772 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7773 if (branch_type == NULL)
7774 {
7775 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
7776 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7777 TYPE_NFIELDS (rtype) -= 1;
7778 }
7779 else
7780 {
7781 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7782 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7783 fld_bit_len =
7784 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
7785 TARGET_CHAR_BIT;
7786 if (off + fld_bit_len > bit_len)
7787 bit_len = off + fld_bit_len;
7788 TYPE_LENGTH (rtype) =
7789 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7790 }
7791 }
7792
714e53ab
PH
7793 /* According to exp_dbug.ads, the size of TYPE for variable-size records
7794 should contain the alignment of that record, which should be a strictly
7795 positive value. If null or negative, then something is wrong, most
7796 probably in the debug info. In that case, we don't round up the size
0963b4bd 7797 of the resulting type. If this record is not part of another structure,
714e53ab
PH
7798 the current RTYPE length might be good enough for our purposes. */
7799 if (TYPE_LENGTH (type) <= 0)
7800 {
323e0a4a
AC
7801 if (TYPE_NAME (rtype))
7802 warning (_("Invalid type size for `%s' detected: %d."),
7803 TYPE_NAME (rtype), TYPE_LENGTH (type));
7804 else
7805 warning (_("Invalid type size for <unnamed> detected: %d."),
7806 TYPE_LENGTH (type));
714e53ab
PH
7807 }
7808 else
7809 {
7810 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
7811 TYPE_LENGTH (type));
7812 }
14f9c5c9
AS
7813
7814 value_free_to_mark (mark);
d2e4a39e 7815 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 7816 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
7817 return rtype;
7818}
7819
4c4b4cd2
PH
7820/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7821 of 1. */
14f9c5c9 7822
d2e4a39e 7823static struct type *
fc1a4b47 7824template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
7825 CORE_ADDR address, struct value *dval0)
7826{
7827 return ada_template_to_fixed_record_type_1 (type, valaddr,
7828 address, dval0, 1);
7829}
7830
7831/* An ordinary record type in which ___XVL-convention fields and
7832 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7833 static approximations, containing all possible fields. Uses
7834 no runtime values. Useless for use in values, but that's OK,
7835 since the results are used only for type determinations. Works on both
7836 structs and unions. Representation note: to save space, we memorize
7837 the result of this function in the TYPE_TARGET_TYPE of the
7838 template type. */
7839
7840static struct type *
7841template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
7842{
7843 struct type *type;
7844 int nfields;
7845 int f;
7846
4c4b4cd2
PH
7847 if (TYPE_TARGET_TYPE (type0) != NULL)
7848 return TYPE_TARGET_TYPE (type0);
7849
7850 nfields = TYPE_NFIELDS (type0);
7851 type = type0;
14f9c5c9
AS
7852
7853 for (f = 0; f < nfields; f += 1)
7854 {
61ee279c 7855 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
4c4b4cd2 7856 struct type *new_type;
14f9c5c9 7857
4c4b4cd2
PH
7858 if (is_dynamic_field (type0, f))
7859 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
14f9c5c9 7860 else
f192137b 7861 new_type = static_unwrap_type (field_type);
4c4b4cd2
PH
7862 if (type == type0 && new_type != field_type)
7863 {
e9bb382b 7864 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
4c4b4cd2
PH
7865 TYPE_CODE (type) = TYPE_CODE (type0);
7866 INIT_CPLUS_SPECIFIC (type);
7867 TYPE_NFIELDS (type) = nfields;
7868 TYPE_FIELDS (type) = (struct field *)
7869 TYPE_ALLOC (type, nfields * sizeof (struct field));
7870 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
7871 sizeof (struct field) * nfields);
7872 TYPE_NAME (type) = ada_type_name (type0);
7873 TYPE_TAG_NAME (type) = NULL;
876cecd0 7874 TYPE_FIXED_INSTANCE (type) = 1;
4c4b4cd2
PH
7875 TYPE_LENGTH (type) = 0;
7876 }
7877 TYPE_FIELD_TYPE (type, f) = new_type;
7878 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
14f9c5c9 7879 }
14f9c5c9
AS
7880 return type;
7881}
7882
4c4b4cd2 7883/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
7884 whose address in memory is ADDRESS, returns a revision of TYPE,
7885 which should be a non-dynamic-sized record, in which the variant
7886 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
7887 for discriminant values in DVAL0, which can be NULL if the record
7888 contains the necessary discriminant values. */
7889
d2e4a39e 7890static struct type *
fc1a4b47 7891to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 7892 CORE_ADDR address, struct value *dval0)
14f9c5c9 7893{
d2e4a39e 7894 struct value *mark = value_mark ();
4c4b4cd2 7895 struct value *dval;
d2e4a39e 7896 struct type *rtype;
14f9c5c9
AS
7897 struct type *branch_type;
7898 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 7899 int variant_field = variant_field_index (type);
14f9c5c9 7900
4c4b4cd2 7901 if (variant_field == -1)
14f9c5c9
AS
7902 return type;
7903
4c4b4cd2
PH
7904 if (dval0 == NULL)
7905 dval = value_from_contents_and_address (type, valaddr, address);
7906 else
7907 dval = dval0;
7908
e9bb382b 7909 rtype = alloc_type_copy (type);
14f9c5c9 7910 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
7911 INIT_CPLUS_SPECIFIC (rtype);
7912 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
7913 TYPE_FIELDS (rtype) =
7914 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7915 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 7916 sizeof (struct field) * nfields);
14f9c5c9
AS
7917 TYPE_NAME (rtype) = ada_type_name (type);
7918 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7919 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
7920 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7921
4c4b4cd2
PH
7922 branch_type = to_fixed_variant_branch_type
7923 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 7924 cond_offset_host (valaddr,
4c4b4cd2
PH
7925 TYPE_FIELD_BITPOS (type, variant_field)
7926 / TARGET_CHAR_BIT),
d2e4a39e 7927 cond_offset_target (address,
4c4b4cd2
PH
7928 TYPE_FIELD_BITPOS (type, variant_field)
7929 / TARGET_CHAR_BIT), dval);
d2e4a39e 7930 if (branch_type == NULL)
14f9c5c9 7931 {
4c4b4cd2 7932 int f;
5b4ee69b 7933
4c4b4cd2
PH
7934 for (f = variant_field + 1; f < nfields; f += 1)
7935 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 7936 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
7937 }
7938 else
7939 {
4c4b4cd2
PH
7940 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7941 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7942 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 7943 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 7944 }
4c4b4cd2 7945 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 7946
4c4b4cd2 7947 value_free_to_mark (mark);
14f9c5c9
AS
7948 return rtype;
7949}
7950
7951/* An ordinary record type (with fixed-length fields) that describes
7952 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7953 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
7954 should be in DVAL, a record value; it may be NULL if the object
7955 at ADDR itself contains any necessary discriminant values.
7956 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7957 values from the record are needed. Except in the case that DVAL,
7958 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7959 unchecked) is replaced by a particular branch of the variant.
7960
7961 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7962 is questionable and may be removed. It can arise during the
7963 processing of an unconstrained-array-of-record type where all the
7964 variant branches have exactly the same size. This is because in
7965 such cases, the compiler does not bother to use the XVS convention
7966 when encoding the record. I am currently dubious of this
7967 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 7968
d2e4a39e 7969static struct type *
fc1a4b47 7970to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 7971 CORE_ADDR address, struct value *dval)
14f9c5c9 7972{
d2e4a39e 7973 struct type *templ_type;
14f9c5c9 7974
876cecd0 7975 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
7976 return type0;
7977
d2e4a39e 7978 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
7979
7980 if (templ_type != NULL)
7981 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
7982 else if (variant_field_index (type0) >= 0)
7983 {
7984 if (dval == NULL && valaddr == NULL && address == 0)
7985 return type0;
7986 return to_record_with_fixed_variant_part (type0, valaddr, address,
7987 dval);
7988 }
14f9c5c9
AS
7989 else
7990 {
876cecd0 7991 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
7992 return type0;
7993 }
7994
7995}
7996
7997/* An ordinary record type (with fixed-length fields) that describes
7998 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7999 union type. Any necessary discriminants' values should be in DVAL,
8000 a record value. That is, this routine selects the appropriate
8001 branch of the union at ADDR according to the discriminant value
b1f33ddd 8002 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8003 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8004
d2e4a39e 8005static struct type *
fc1a4b47 8006to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8007 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8008{
8009 int which;
d2e4a39e
AS
8010 struct type *templ_type;
8011 struct type *var_type;
14f9c5c9
AS
8012
8013 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8014 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8015 else
14f9c5c9
AS
8016 var_type = var_type0;
8017
8018 templ_type = ada_find_parallel_type (var_type, "___XVU");
8019
8020 if (templ_type != NULL)
8021 var_type = templ_type;
8022
b1f33ddd
JB
8023 if (is_unchecked_variant (var_type, value_type (dval)))
8024 return var_type0;
d2e4a39e
AS
8025 which =
8026 ada_which_variant_applies (var_type,
0fd88904 8027 value_type (dval), value_contents (dval));
14f9c5c9
AS
8028
8029 if (which < 0)
e9bb382b 8030 return empty_record (var_type);
14f9c5c9 8031 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8032 return to_fixed_record_type
d2e4a39e
AS
8033 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8034 valaddr, address, dval);
4c4b4cd2 8035 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8036 return
8037 to_fixed_record_type
8038 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8039 else
8040 return TYPE_FIELD_TYPE (var_type, which);
8041}
8042
8043/* Assuming that TYPE0 is an array type describing the type of a value
8044 at ADDR, and that DVAL describes a record containing any
8045 discriminants used in TYPE0, returns a type for the value that
8046 contains no dynamic components (that is, no components whose sizes
8047 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8048 true, gives an error message if the resulting type's size is over
4c4b4cd2 8049 varsize_limit. */
14f9c5c9 8050
d2e4a39e
AS
8051static struct type *
8052to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8053 int ignore_too_big)
14f9c5c9 8054{
d2e4a39e
AS
8055 struct type *index_type_desc;
8056 struct type *result;
ad82864c 8057 int constrained_packed_array_p;
14f9c5c9 8058
b0dd7688 8059 type0 = ada_check_typedef (type0);
284614f0 8060 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8061 return type0;
14f9c5c9 8062
ad82864c
JB
8063 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8064 if (constrained_packed_array_p)
8065 type0 = decode_constrained_packed_array_type (type0);
284614f0 8066
14f9c5c9 8067 index_type_desc = ada_find_parallel_type (type0, "___XA");
28c85d6c 8068 ada_fixup_array_indexes_type (index_type_desc);
14f9c5c9
AS
8069 if (index_type_desc == NULL)
8070 {
61ee279c 8071 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8072
14f9c5c9 8073 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8074 depend on the contents of the array in properly constructed
8075 debugging data. */
529cad9c
PH
8076 /* Create a fixed version of the array element type.
8077 We're not providing the address of an element here,
e1d5a0d2 8078 and thus the actual object value cannot be inspected to do
529cad9c
PH
8079 the conversion. This should not be a problem, since arrays of
8080 unconstrained objects are not allowed. In particular, all
8081 the elements of an array of a tagged type should all be of
8082 the same type specified in the debugging info. No need to
8083 consult the object tag. */
1ed6ede0 8084 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8085
284614f0
JB
8086 /* Make sure we always create a new array type when dealing with
8087 packed array types, since we're going to fix-up the array
8088 type length and element bitsize a little further down. */
ad82864c 8089 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8090 result = type0;
14f9c5c9 8091 else
e9bb382b 8092 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8093 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8094 }
8095 else
8096 {
8097 int i;
8098 struct type *elt_type0;
8099
8100 elt_type0 = type0;
8101 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8102 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8103
8104 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8105 depend on the contents of the array in properly constructed
8106 debugging data. */
529cad9c
PH
8107 /* Create a fixed version of the array element type.
8108 We're not providing the address of an element here,
e1d5a0d2 8109 and thus the actual object value cannot be inspected to do
529cad9c
PH
8110 the conversion. This should not be a problem, since arrays of
8111 unconstrained objects are not allowed. In particular, all
8112 the elements of an array of a tagged type should all be of
8113 the same type specified in the debugging info. No need to
8114 consult the object tag. */
1ed6ede0
JB
8115 result =
8116 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8117
8118 elt_type0 = type0;
14f9c5c9 8119 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8120 {
8121 struct type *range_type =
28c85d6c 8122 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8123
e9bb382b 8124 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8125 result, range_type);
1ce677a4 8126 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8127 }
d2e4a39e 8128 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8129 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8130 }
8131
2e6fda7d
JB
8132 /* We want to preserve the type name. This can be useful when
8133 trying to get the type name of a value that has already been
8134 printed (for instance, if the user did "print VAR; whatis $". */
8135 TYPE_NAME (result) = TYPE_NAME (type0);
8136
ad82864c 8137 if (constrained_packed_array_p)
284614f0
JB
8138 {
8139 /* So far, the resulting type has been created as if the original
8140 type was a regular (non-packed) array type. As a result, the
8141 bitsize of the array elements needs to be set again, and the array
8142 length needs to be recomputed based on that bitsize. */
8143 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8144 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8145
8146 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8147 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8148 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8149 TYPE_LENGTH (result)++;
8150 }
8151
876cecd0 8152 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8153 return result;
d2e4a39e 8154}
14f9c5c9
AS
8155
8156
8157/* A standard type (containing no dynamically sized components)
8158 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8159 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8160 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8161 ADDRESS or in VALADDR contains these discriminants.
8162
1ed6ede0
JB
8163 If CHECK_TAG is not null, in the case of tagged types, this function
8164 attempts to locate the object's tag and use it to compute the actual
8165 type. However, when ADDRESS is null, we cannot use it to determine the
8166 location of the tag, and therefore compute the tagged type's actual type.
8167 So we return the tagged type without consulting the tag. */
529cad9c 8168
f192137b
JB
8169static struct type *
8170ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 8171 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 8172{
61ee279c 8173 type = ada_check_typedef (type);
d2e4a39e
AS
8174 switch (TYPE_CODE (type))
8175 {
8176 default:
14f9c5c9 8177 return type;
d2e4a39e 8178 case TYPE_CODE_STRUCT:
4c4b4cd2 8179 {
76a01679 8180 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
8181 struct type *fixed_record_type =
8182 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 8183
529cad9c
PH
8184 /* If STATIC_TYPE is a tagged type and we know the object's address,
8185 then we can determine its tag, and compute the object's actual
0963b4bd 8186 type from there. Note that we have to use the fixed record
1ed6ede0
JB
8187 type (the parent part of the record may have dynamic fields
8188 and the way the location of _tag is expressed may depend on
8189 them). */
529cad9c 8190
1ed6ede0 8191 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 8192 {
b50d69b5
JG
8193 struct value *tag =
8194 value_tag_from_contents_and_address
8195 (fixed_record_type,
8196 valaddr,
8197 address);
8198 struct type *real_type = type_from_tag (tag);
8199 struct value *obj =
8200 value_from_contents_and_address (fixed_record_type,
8201 valaddr,
8202 address);
76a01679 8203 if (real_type != NULL)
b50d69b5
JG
8204 return to_fixed_record_type
8205 (real_type, NULL,
8206 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 8207 }
4af88198
JB
8208
8209 /* Check to see if there is a parallel ___XVZ variable.
8210 If there is, then it provides the actual size of our type. */
8211 else if (ada_type_name (fixed_record_type) != NULL)
8212 {
0d5cff50 8213 const char *name = ada_type_name (fixed_record_type);
4af88198
JB
8214 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
8215 int xvz_found = 0;
8216 LONGEST size;
8217
88c15c34 8218 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
4af88198
JB
8219 size = get_int_var_value (xvz_name, &xvz_found);
8220 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8221 {
8222 fixed_record_type = copy_type (fixed_record_type);
8223 TYPE_LENGTH (fixed_record_type) = size;
8224
8225 /* The FIXED_RECORD_TYPE may have be a stub. We have
8226 observed this when the debugging info is STABS, and
8227 apparently it is something that is hard to fix.
8228
8229 In practice, we don't need the actual type definition
8230 at all, because the presence of the XVZ variable allows us
8231 to assume that there must be a XVS type as well, which we
8232 should be able to use later, when we need the actual type
8233 definition.
8234
8235 In the meantime, pretend that the "fixed" type we are
8236 returning is NOT a stub, because this can cause trouble
8237 when using this type to create new types targeting it.
8238 Indeed, the associated creation routines often check
8239 whether the target type is a stub and will try to replace
0963b4bd 8240 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
8241 might cause the new type to have the wrong size too.
8242 Consider the case of an array, for instance, where the size
8243 of the array is computed from the number of elements in
8244 our array multiplied by the size of its element. */
8245 TYPE_STUB (fixed_record_type) = 0;
8246 }
8247 }
1ed6ede0 8248 return fixed_record_type;
4c4b4cd2 8249 }
d2e4a39e 8250 case TYPE_CODE_ARRAY:
4c4b4cd2 8251 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
8252 case TYPE_CODE_UNION:
8253 if (dval == NULL)
4c4b4cd2 8254 return type;
d2e4a39e 8255 else
4c4b4cd2 8256 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 8257 }
14f9c5c9
AS
8258}
8259
f192137b
JB
8260/* The same as ada_to_fixed_type_1, except that it preserves the type
8261 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
8262
8263 The typedef layer needs be preserved in order to differentiate between
8264 arrays and array pointers when both types are implemented using the same
8265 fat pointer. In the array pointer case, the pointer is encoded as
8266 a typedef of the pointer type. For instance, considering:
8267
8268 type String_Access is access String;
8269 S1 : String_Access := null;
8270
8271 To the debugger, S1 is defined as a typedef of type String. But
8272 to the user, it is a pointer. So if the user tries to print S1,
8273 we should not dereference the array, but print the array address
8274 instead.
8275
8276 If we didn't preserve the typedef layer, we would lose the fact that
8277 the type is to be presented as a pointer (needs de-reference before
8278 being printed). And we would also use the source-level type name. */
f192137b
JB
8279
8280struct type *
8281ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8282 CORE_ADDR address, struct value *dval, int check_tag)
8283
8284{
8285 struct type *fixed_type =
8286 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8287
96dbd2c1
JB
8288 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8289 then preserve the typedef layer.
8290
8291 Implementation note: We can only check the main-type portion of
8292 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8293 from TYPE now returns a type that has the same instance flags
8294 as TYPE. For instance, if TYPE is a "typedef const", and its
8295 target type is a "struct", then the typedef elimination will return
8296 a "const" version of the target type. See check_typedef for more
8297 details about how the typedef layer elimination is done.
8298
8299 brobecker/2010-11-19: It seems to me that the only case where it is
8300 useful to preserve the typedef layer is when dealing with fat pointers.
8301 Perhaps, we could add a check for that and preserve the typedef layer
8302 only in that situation. But this seems unecessary so far, probably
8303 because we call check_typedef/ada_check_typedef pretty much everywhere.
8304 */
f192137b 8305 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 8306 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 8307 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
8308 return type;
8309
8310 return fixed_type;
8311}
8312
14f9c5c9 8313/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 8314 TYPE0, but based on no runtime data. */
14f9c5c9 8315
d2e4a39e
AS
8316static struct type *
8317to_static_fixed_type (struct type *type0)
14f9c5c9 8318{
d2e4a39e 8319 struct type *type;
14f9c5c9
AS
8320
8321 if (type0 == NULL)
8322 return NULL;
8323
876cecd0 8324 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8325 return type0;
8326
61ee279c 8327 type0 = ada_check_typedef (type0);
d2e4a39e 8328
14f9c5c9
AS
8329 switch (TYPE_CODE (type0))
8330 {
8331 default:
8332 return type0;
8333 case TYPE_CODE_STRUCT:
8334 type = dynamic_template_type (type0);
d2e4a39e 8335 if (type != NULL)
4c4b4cd2
PH
8336 return template_to_static_fixed_type (type);
8337 else
8338 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8339 case TYPE_CODE_UNION:
8340 type = ada_find_parallel_type (type0, "___XVU");
8341 if (type != NULL)
4c4b4cd2
PH
8342 return template_to_static_fixed_type (type);
8343 else
8344 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8345 }
8346}
8347
4c4b4cd2
PH
8348/* A static approximation of TYPE with all type wrappers removed. */
8349
d2e4a39e
AS
8350static struct type *
8351static_unwrap_type (struct type *type)
14f9c5c9
AS
8352{
8353 if (ada_is_aligner_type (type))
8354 {
61ee279c 8355 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 8356 if (ada_type_name (type1) == NULL)
4c4b4cd2 8357 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
8358
8359 return static_unwrap_type (type1);
8360 }
d2e4a39e 8361 else
14f9c5c9 8362 {
d2e4a39e 8363 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 8364
d2e4a39e 8365 if (raw_real_type == type)
4c4b4cd2 8366 return type;
14f9c5c9 8367 else
4c4b4cd2 8368 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
8369 }
8370}
8371
8372/* In some cases, incomplete and private types require
4c4b4cd2 8373 cross-references that are not resolved as records (for example,
14f9c5c9
AS
8374 type Foo;
8375 type FooP is access Foo;
8376 V: FooP;
8377 type Foo is array ...;
4c4b4cd2 8378 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
8379 cross-references to such types, we instead substitute for FooP a
8380 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 8381 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
8382
8383/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
8384 exists, otherwise TYPE. */
8385
d2e4a39e 8386struct type *
61ee279c 8387ada_check_typedef (struct type *type)
14f9c5c9 8388{
727e3d2e
JB
8389 if (type == NULL)
8390 return NULL;
8391
720d1a40
JB
8392 /* If our type is a typedef type of a fat pointer, then we're done.
8393 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8394 what allows us to distinguish between fat pointers that represent
8395 array types, and fat pointers that represent array access types
8396 (in both cases, the compiler implements them as fat pointers). */
8397 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8398 && is_thick_pntr (ada_typedef_target_type (type)))
8399 return type;
8400
14f9c5c9
AS
8401 CHECK_TYPEDEF (type);
8402 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 8403 || !TYPE_STUB (type)
14f9c5c9
AS
8404 || TYPE_TAG_NAME (type) == NULL)
8405 return type;
d2e4a39e 8406 else
14f9c5c9 8407 {
0d5cff50 8408 const char *name = TYPE_TAG_NAME (type);
d2e4a39e 8409 struct type *type1 = ada_find_any_type (name);
5b4ee69b 8410
05e522ef
JB
8411 if (type1 == NULL)
8412 return type;
8413
8414 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8415 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
8416 types, only for the typedef-to-array types). If that's the case,
8417 strip the typedef layer. */
8418 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
8419 type1 = ada_check_typedef (type1);
8420
8421 return type1;
14f9c5c9
AS
8422 }
8423}
8424
8425/* A value representing the data at VALADDR/ADDRESS as described by
8426 type TYPE0, but with a standard (static-sized) type that correctly
8427 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8428 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 8429 creation of struct values]. */
14f9c5c9 8430
4c4b4cd2
PH
8431static struct value *
8432ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8433 struct value *val0)
14f9c5c9 8434{
1ed6ede0 8435 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 8436
14f9c5c9
AS
8437 if (type == type0 && val0 != NULL)
8438 return val0;
d2e4a39e 8439 else
4c4b4cd2
PH
8440 return value_from_contents_and_address (type, 0, address);
8441}
8442
8443/* A value representing VAL, but with a standard (static-sized) type
8444 that correctly describes it. Does not necessarily create a new
8445 value. */
8446
0c3acc09 8447struct value *
4c4b4cd2
PH
8448ada_to_fixed_value (struct value *val)
8449{
c48db5ca
JB
8450 val = unwrap_value (val);
8451 val = ada_to_fixed_value_create (value_type (val),
8452 value_address (val),
8453 val);
8454 return val;
14f9c5c9 8455}
d2e4a39e 8456\f
14f9c5c9 8457
14f9c5c9
AS
8458/* Attributes */
8459
4c4b4cd2
PH
8460/* Table mapping attribute numbers to names.
8461 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 8462
d2e4a39e 8463static const char *attribute_names[] = {
14f9c5c9
AS
8464 "<?>",
8465
d2e4a39e 8466 "first",
14f9c5c9
AS
8467 "last",
8468 "length",
8469 "image",
14f9c5c9
AS
8470 "max",
8471 "min",
4c4b4cd2
PH
8472 "modulus",
8473 "pos",
8474 "size",
8475 "tag",
14f9c5c9 8476 "val",
14f9c5c9
AS
8477 0
8478};
8479
d2e4a39e 8480const char *
4c4b4cd2 8481ada_attribute_name (enum exp_opcode n)
14f9c5c9 8482{
4c4b4cd2
PH
8483 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8484 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
8485 else
8486 return attribute_names[0];
8487}
8488
4c4b4cd2 8489/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 8490
4c4b4cd2
PH
8491static LONGEST
8492pos_atr (struct value *arg)
14f9c5c9 8493{
24209737
PH
8494 struct value *val = coerce_ref (arg);
8495 struct type *type = value_type (val);
14f9c5c9 8496
d2e4a39e 8497 if (!discrete_type_p (type))
323e0a4a 8498 error (_("'POS only defined on discrete types"));
14f9c5c9
AS
8499
8500 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8501 {
8502 int i;
24209737 8503 LONGEST v = value_as_long (val);
14f9c5c9 8504
d2e4a39e 8505 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2 8506 {
14e75d8e 8507 if (v == TYPE_FIELD_ENUMVAL (type, i))
4c4b4cd2
PH
8508 return i;
8509 }
323e0a4a 8510 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9
AS
8511 }
8512 else
24209737 8513 return value_as_long (val);
4c4b4cd2
PH
8514}
8515
8516static struct value *
3cb382c9 8517value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 8518{
3cb382c9 8519 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
8520}
8521
4c4b4cd2 8522/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 8523
d2e4a39e
AS
8524static struct value *
8525value_val_atr (struct type *type, struct value *arg)
14f9c5c9 8526{
d2e4a39e 8527 if (!discrete_type_p (type))
323e0a4a 8528 error (_("'VAL only defined on discrete types"));
df407dfe 8529 if (!integer_type_p (value_type (arg)))
323e0a4a 8530 error (_("'VAL requires integral argument"));
14f9c5c9
AS
8531
8532 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8533 {
8534 long pos = value_as_long (arg);
5b4ee69b 8535
14f9c5c9 8536 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 8537 error (_("argument to 'VAL out of range"));
14e75d8e 8538 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
8539 }
8540 else
8541 return value_from_longest (type, value_as_long (arg));
8542}
14f9c5c9 8543\f
d2e4a39e 8544
4c4b4cd2 8545 /* Evaluation */
14f9c5c9 8546
4c4b4cd2
PH
8547/* True if TYPE appears to be an Ada character type.
8548 [At the moment, this is true only for Character and Wide_Character;
8549 It is a heuristic test that could stand improvement]. */
14f9c5c9 8550
d2e4a39e
AS
8551int
8552ada_is_character_type (struct type *type)
14f9c5c9 8553{
7b9f71f2
JB
8554 const char *name;
8555
8556 /* If the type code says it's a character, then assume it really is,
8557 and don't check any further. */
8558 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
8559 return 1;
8560
8561 /* Otherwise, assume it's a character type iff it is a discrete type
8562 with a known character type name. */
8563 name = ada_type_name (type);
8564 return (name != NULL
8565 && (TYPE_CODE (type) == TYPE_CODE_INT
8566 || TYPE_CODE (type) == TYPE_CODE_RANGE)
8567 && (strcmp (name, "character") == 0
8568 || strcmp (name, "wide_character") == 0
5a517ebd 8569 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 8570 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
8571}
8572
4c4b4cd2 8573/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
8574
8575int
ebf56fd3 8576ada_is_string_type (struct type *type)
14f9c5c9 8577{
61ee279c 8578 type = ada_check_typedef (type);
d2e4a39e 8579 if (type != NULL
14f9c5c9 8580 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
8581 && (ada_is_simple_array_type (type)
8582 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
8583 && ada_array_arity (type) == 1)
8584 {
8585 struct type *elttype = ada_array_element_type (type, 1);
8586
8587 return ada_is_character_type (elttype);
8588 }
d2e4a39e 8589 else
14f9c5c9
AS
8590 return 0;
8591}
8592
5bf03f13
JB
8593/* The compiler sometimes provides a parallel XVS type for a given
8594 PAD type. Normally, it is safe to follow the PAD type directly,
8595 but older versions of the compiler have a bug that causes the offset
8596 of its "F" field to be wrong. Following that field in that case
8597 would lead to incorrect results, but this can be worked around
8598 by ignoring the PAD type and using the associated XVS type instead.
8599
8600 Set to True if the debugger should trust the contents of PAD types.
8601 Otherwise, ignore the PAD type if there is a parallel XVS type. */
8602static int trust_pad_over_xvs = 1;
14f9c5c9
AS
8603
8604/* True if TYPE is a struct type introduced by the compiler to force the
8605 alignment of a value. Such types have a single field with a
4c4b4cd2 8606 distinctive name. */
14f9c5c9
AS
8607
8608int
ebf56fd3 8609ada_is_aligner_type (struct type *type)
14f9c5c9 8610{
61ee279c 8611 type = ada_check_typedef (type);
714e53ab 8612
5bf03f13 8613 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
8614 return 0;
8615
14f9c5c9 8616 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
8617 && TYPE_NFIELDS (type) == 1
8618 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
8619}
8620
8621/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 8622 the parallel type. */
14f9c5c9 8623
d2e4a39e
AS
8624struct type *
8625ada_get_base_type (struct type *raw_type)
14f9c5c9 8626{
d2e4a39e
AS
8627 struct type *real_type_namer;
8628 struct type *raw_real_type;
14f9c5c9
AS
8629
8630 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
8631 return raw_type;
8632
284614f0
JB
8633 if (ada_is_aligner_type (raw_type))
8634 /* The encoding specifies that we should always use the aligner type.
8635 So, even if this aligner type has an associated XVS type, we should
8636 simply ignore it.
8637
8638 According to the compiler gurus, an XVS type parallel to an aligner
8639 type may exist because of a stabs limitation. In stabs, aligner
8640 types are empty because the field has a variable-sized type, and
8641 thus cannot actually be used as an aligner type. As a result,
8642 we need the associated parallel XVS type to decode the type.
8643 Since the policy in the compiler is to not change the internal
8644 representation based on the debugging info format, we sometimes
8645 end up having a redundant XVS type parallel to the aligner type. */
8646 return raw_type;
8647
14f9c5c9 8648 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 8649 if (real_type_namer == NULL
14f9c5c9
AS
8650 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
8651 || TYPE_NFIELDS (real_type_namer) != 1)
8652 return raw_type;
8653
f80d3ff2
JB
8654 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
8655 {
8656 /* This is an older encoding form where the base type needs to be
8657 looked up by name. We prefer the newer enconding because it is
8658 more efficient. */
8659 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
8660 if (raw_real_type == NULL)
8661 return raw_type;
8662 else
8663 return raw_real_type;
8664 }
8665
8666 /* The field in our XVS type is a reference to the base type. */
8667 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 8668}
14f9c5c9 8669
4c4b4cd2 8670/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 8671
d2e4a39e
AS
8672struct type *
8673ada_aligned_type (struct type *type)
14f9c5c9
AS
8674{
8675 if (ada_is_aligner_type (type))
8676 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
8677 else
8678 return ada_get_base_type (type);
8679}
8680
8681
8682/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 8683 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 8684
fc1a4b47
AC
8685const gdb_byte *
8686ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 8687{
d2e4a39e 8688 if (ada_is_aligner_type (type))
14f9c5c9 8689 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
8690 valaddr +
8691 TYPE_FIELD_BITPOS (type,
8692 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
8693 else
8694 return valaddr;
8695}
8696
4c4b4cd2
PH
8697
8698
14f9c5c9 8699/* The printed representation of an enumeration literal with encoded
4c4b4cd2 8700 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
8701const char *
8702ada_enum_name (const char *name)
14f9c5c9 8703{
4c4b4cd2
PH
8704 static char *result;
8705 static size_t result_len = 0;
d2e4a39e 8706 char *tmp;
14f9c5c9 8707
4c4b4cd2
PH
8708 /* First, unqualify the enumeration name:
8709 1. Search for the last '.' character. If we find one, then skip
177b42fe 8710 all the preceding characters, the unqualified name starts
76a01679 8711 right after that dot.
4c4b4cd2 8712 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
8713 translates dots into "__". Search forward for double underscores,
8714 but stop searching when we hit an overloading suffix, which is
8715 of the form "__" followed by digits. */
4c4b4cd2 8716
c3e5cd34
PH
8717 tmp = strrchr (name, '.');
8718 if (tmp != NULL)
4c4b4cd2
PH
8719 name = tmp + 1;
8720 else
14f9c5c9 8721 {
4c4b4cd2
PH
8722 while ((tmp = strstr (name, "__")) != NULL)
8723 {
8724 if (isdigit (tmp[2]))
8725 break;
8726 else
8727 name = tmp + 2;
8728 }
14f9c5c9
AS
8729 }
8730
8731 if (name[0] == 'Q')
8732 {
14f9c5c9 8733 int v;
5b4ee69b 8734
14f9c5c9 8735 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
8736 {
8737 if (sscanf (name + 2, "%x", &v) != 1)
8738 return name;
8739 }
14f9c5c9 8740 else
4c4b4cd2 8741 return name;
14f9c5c9 8742
4c4b4cd2 8743 GROW_VECT (result, result_len, 16);
14f9c5c9 8744 if (isascii (v) && isprint (v))
88c15c34 8745 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 8746 else if (name[1] == 'U')
88c15c34 8747 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 8748 else
88c15c34 8749 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
8750
8751 return result;
8752 }
d2e4a39e 8753 else
4c4b4cd2 8754 {
c3e5cd34
PH
8755 tmp = strstr (name, "__");
8756 if (tmp == NULL)
8757 tmp = strstr (name, "$");
8758 if (tmp != NULL)
4c4b4cd2
PH
8759 {
8760 GROW_VECT (result, result_len, tmp - name + 1);
8761 strncpy (result, name, tmp - name);
8762 result[tmp - name] = '\0';
8763 return result;
8764 }
8765
8766 return name;
8767 }
14f9c5c9
AS
8768}
8769
14f9c5c9
AS
8770/* Evaluate the subexpression of EXP starting at *POS as for
8771 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 8772 expression. */
14f9c5c9 8773
d2e4a39e
AS
8774static struct value *
8775evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 8776{
4b27a620 8777 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
8778}
8779
8780/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 8781 value it wraps. */
14f9c5c9 8782
d2e4a39e
AS
8783static struct value *
8784unwrap_value (struct value *val)
14f9c5c9 8785{
df407dfe 8786 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 8787
14f9c5c9
AS
8788 if (ada_is_aligner_type (type))
8789 {
de4d072f 8790 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 8791 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 8792
14f9c5c9 8793 if (ada_type_name (val_type) == NULL)
4c4b4cd2 8794 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
8795
8796 return unwrap_value (v);
8797 }
d2e4a39e 8798 else
14f9c5c9 8799 {
d2e4a39e 8800 struct type *raw_real_type =
61ee279c 8801 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 8802
5bf03f13
JB
8803 /* If there is no parallel XVS or XVE type, then the value is
8804 already unwrapped. Return it without further modification. */
8805 if ((type == raw_real_type)
8806 && ada_find_parallel_type (type, "___XVE") == NULL)
8807 return val;
14f9c5c9 8808
d2e4a39e 8809 return
4c4b4cd2
PH
8810 coerce_unspec_val_to_type
8811 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 8812 value_address (val),
1ed6ede0 8813 NULL, 1));
14f9c5c9
AS
8814 }
8815}
d2e4a39e
AS
8816
8817static struct value *
8818cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
8819{
8820 LONGEST val;
8821
df407dfe 8822 if (type == value_type (arg))
14f9c5c9 8823 return arg;
df407dfe 8824 else if (ada_is_fixed_point_type (value_type (arg)))
d2e4a39e 8825 val = ada_float_to_fixed (type,
df407dfe 8826 ada_fixed_to_float (value_type (arg),
4c4b4cd2 8827 value_as_long (arg)));
d2e4a39e 8828 else
14f9c5c9 8829 {
a53b7a21 8830 DOUBLEST argd = value_as_double (arg);
5b4ee69b 8831
14f9c5c9
AS
8832 val = ada_float_to_fixed (type, argd);
8833 }
8834
8835 return value_from_longest (type, val);
8836}
8837
d2e4a39e 8838static struct value *
a53b7a21 8839cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 8840{
df407dfe 8841 DOUBLEST val = ada_fixed_to_float (value_type (arg),
4c4b4cd2 8842 value_as_long (arg));
5b4ee69b 8843
a53b7a21 8844 return value_from_double (type, val);
14f9c5c9
AS
8845}
8846
d99dcf51
JB
8847/* Given two array types T1 and T2, return nonzero iff both arrays
8848 contain the same number of elements. */
8849
8850static int
8851ada_same_array_size_p (struct type *t1, struct type *t2)
8852{
8853 LONGEST lo1, hi1, lo2, hi2;
8854
8855 /* Get the array bounds in order to verify that the size of
8856 the two arrays match. */
8857 if (!get_array_bounds (t1, &lo1, &hi1)
8858 || !get_array_bounds (t2, &lo2, &hi2))
8859 error (_("unable to determine array bounds"));
8860
8861 /* To make things easier for size comparison, normalize a bit
8862 the case of empty arrays by making sure that the difference
8863 between upper bound and lower bound is always -1. */
8864 if (lo1 > hi1)
8865 hi1 = lo1 - 1;
8866 if (lo2 > hi2)
8867 hi2 = lo2 - 1;
8868
8869 return (hi1 - lo1 == hi2 - lo2);
8870}
8871
8872/* Assuming that VAL is an array of integrals, and TYPE represents
8873 an array with the same number of elements, but with wider integral
8874 elements, return an array "casted" to TYPE. In practice, this
8875 means that the returned array is built by casting each element
8876 of the original array into TYPE's (wider) element type. */
8877
8878static struct value *
8879ada_promote_array_of_integrals (struct type *type, struct value *val)
8880{
8881 struct type *elt_type = TYPE_TARGET_TYPE (type);
8882 LONGEST lo, hi;
8883 struct value *res;
8884 LONGEST i;
8885
8886 /* Verify that both val and type are arrays of scalars, and
8887 that the size of val's elements is smaller than the size
8888 of type's element. */
8889 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
8890 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
8891 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
8892 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
8893 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
8894 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
8895
8896 if (!get_array_bounds (type, &lo, &hi))
8897 error (_("unable to determine array bounds"));
8898
8899 res = allocate_value (type);
8900
8901 /* Promote each array element. */
8902 for (i = 0; i < hi - lo + 1; i++)
8903 {
8904 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
8905
8906 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
8907 value_contents_all (elt), TYPE_LENGTH (elt_type));
8908 }
8909
8910 return res;
8911}
8912
4c4b4cd2
PH
8913/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8914 return the converted value. */
8915
d2e4a39e
AS
8916static struct value *
8917coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 8918{
df407dfe 8919 struct type *type2 = value_type (val);
5b4ee69b 8920
14f9c5c9
AS
8921 if (type == type2)
8922 return val;
8923
61ee279c
PH
8924 type2 = ada_check_typedef (type2);
8925 type = ada_check_typedef (type);
14f9c5c9 8926
d2e4a39e
AS
8927 if (TYPE_CODE (type2) == TYPE_CODE_PTR
8928 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
8929 {
8930 val = ada_value_ind (val);
df407dfe 8931 type2 = value_type (val);
14f9c5c9
AS
8932 }
8933
d2e4a39e 8934 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
8935 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
8936 {
d99dcf51
JB
8937 if (!ada_same_array_size_p (type, type2))
8938 error (_("cannot assign arrays of different length"));
8939
8940 if (is_integral_type (TYPE_TARGET_TYPE (type))
8941 && is_integral_type (TYPE_TARGET_TYPE (type2))
8942 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8943 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8944 {
8945 /* Allow implicit promotion of the array elements to
8946 a wider type. */
8947 return ada_promote_array_of_integrals (type, val);
8948 }
8949
8950 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8951 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 8952 error (_("Incompatible types in assignment"));
04624583 8953 deprecated_set_value_type (val, type);
14f9c5c9 8954 }
d2e4a39e 8955 return val;
14f9c5c9
AS
8956}
8957
4c4b4cd2
PH
8958static struct value *
8959ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
8960{
8961 struct value *val;
8962 struct type *type1, *type2;
8963 LONGEST v, v1, v2;
8964
994b9211
AC
8965 arg1 = coerce_ref (arg1);
8966 arg2 = coerce_ref (arg2);
18af8284
JB
8967 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
8968 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 8969
76a01679
JB
8970 if (TYPE_CODE (type1) != TYPE_CODE_INT
8971 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
8972 return value_binop (arg1, arg2, op);
8973
76a01679 8974 switch (op)
4c4b4cd2
PH
8975 {
8976 case BINOP_MOD:
8977 case BINOP_DIV:
8978 case BINOP_REM:
8979 break;
8980 default:
8981 return value_binop (arg1, arg2, op);
8982 }
8983
8984 v2 = value_as_long (arg2);
8985 if (v2 == 0)
323e0a4a 8986 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
8987
8988 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
8989 return value_binop (arg1, arg2, op);
8990
8991 v1 = value_as_long (arg1);
8992 switch (op)
8993 {
8994 case BINOP_DIV:
8995 v = v1 / v2;
76a01679
JB
8996 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
8997 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
8998 break;
8999 case BINOP_REM:
9000 v = v1 % v2;
76a01679
JB
9001 if (v * v1 < 0)
9002 v -= v2;
4c4b4cd2
PH
9003 break;
9004 default:
9005 /* Should not reach this point. */
9006 v = 0;
9007 }
9008
9009 val = allocate_value (type1);
990a07ab 9010 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9011 TYPE_LENGTH (value_type (val)),
9012 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9013 return val;
9014}
9015
9016static int
9017ada_value_equal (struct value *arg1, struct value *arg2)
9018{
df407dfe
AC
9019 if (ada_is_direct_array_type (value_type (arg1))
9020 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9021 {
f58b38bf
JB
9022 /* Automatically dereference any array reference before
9023 we attempt to perform the comparison. */
9024 arg1 = ada_coerce_ref (arg1);
9025 arg2 = ada_coerce_ref (arg2);
9026
4c4b4cd2
PH
9027 arg1 = ada_coerce_to_simple_array (arg1);
9028 arg2 = ada_coerce_to_simple_array (arg2);
df407dfe
AC
9029 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
9030 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
323e0a4a 9031 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9032 /* FIXME: The following works only for types whose
76a01679
JB
9033 representations use all bits (no padding or undefined bits)
9034 and do not have user-defined equality. */
9035 return
df407dfe 9036 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
0fd88904 9037 && memcmp (value_contents (arg1), value_contents (arg2),
df407dfe 9038 TYPE_LENGTH (value_type (arg1))) == 0;
4c4b4cd2
PH
9039 }
9040 return value_equal (arg1, arg2);
9041}
9042
52ce6436
PH
9043/* Total number of component associations in the aggregate starting at
9044 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9045 OP_AGGREGATE. */
52ce6436
PH
9046
9047static int
9048num_component_specs (struct expression *exp, int pc)
9049{
9050 int n, m, i;
5b4ee69b 9051
52ce6436
PH
9052 m = exp->elts[pc + 1].longconst;
9053 pc += 3;
9054 n = 0;
9055 for (i = 0; i < m; i += 1)
9056 {
9057 switch (exp->elts[pc].opcode)
9058 {
9059 default:
9060 n += 1;
9061 break;
9062 case OP_CHOICES:
9063 n += exp->elts[pc + 1].longconst;
9064 break;
9065 }
9066 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9067 }
9068 return n;
9069}
9070
9071/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9072 component of LHS (a simple array or a record), updating *POS past
9073 the expression, assuming that LHS is contained in CONTAINER. Does
9074 not modify the inferior's memory, nor does it modify LHS (unless
9075 LHS == CONTAINER). */
9076
9077static void
9078assign_component (struct value *container, struct value *lhs, LONGEST index,
9079 struct expression *exp, int *pos)
9080{
9081 struct value *mark = value_mark ();
9082 struct value *elt;
5b4ee69b 9083
52ce6436
PH
9084 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
9085 {
22601c15
UW
9086 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9087 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9088
52ce6436
PH
9089 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9090 }
9091 else
9092 {
9093 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9094 elt = ada_to_fixed_value (elt);
52ce6436
PH
9095 }
9096
9097 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9098 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9099 else
9100 value_assign_to_component (container, elt,
9101 ada_evaluate_subexp (NULL, exp, pos,
9102 EVAL_NORMAL));
9103
9104 value_free_to_mark (mark);
9105}
9106
9107/* Assuming that LHS represents an lvalue having a record or array
9108 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9109 of that aggregate's value to LHS, advancing *POS past the
9110 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9111 lvalue containing LHS (possibly LHS itself). Does not modify
9112 the inferior's memory, nor does it modify the contents of
0963b4bd 9113 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9114
9115static struct value *
9116assign_aggregate (struct value *container,
9117 struct value *lhs, struct expression *exp,
9118 int *pos, enum noside noside)
9119{
9120 struct type *lhs_type;
9121 int n = exp->elts[*pos+1].longconst;
9122 LONGEST low_index, high_index;
9123 int num_specs;
9124 LONGEST *indices;
9125 int max_indices, num_indices;
52ce6436 9126 int i;
52ce6436
PH
9127
9128 *pos += 3;
9129 if (noside != EVAL_NORMAL)
9130 {
52ce6436
PH
9131 for (i = 0; i < n; i += 1)
9132 ada_evaluate_subexp (NULL, exp, pos, noside);
9133 return container;
9134 }
9135
9136 container = ada_coerce_ref (container);
9137 if (ada_is_direct_array_type (value_type (container)))
9138 container = ada_coerce_to_simple_array (container);
9139 lhs = ada_coerce_ref (lhs);
9140 if (!deprecated_value_modifiable (lhs))
9141 error (_("Left operand of assignment is not a modifiable lvalue."));
9142
9143 lhs_type = value_type (lhs);
9144 if (ada_is_direct_array_type (lhs_type))
9145 {
9146 lhs = ada_coerce_to_simple_array (lhs);
9147 lhs_type = value_type (lhs);
9148 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9149 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
9150 }
9151 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9152 {
9153 low_index = 0;
9154 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
9155 }
9156 else
9157 error (_("Left-hand side must be array or record."));
9158
9159 num_specs = num_component_specs (exp, *pos - 3);
9160 max_indices = 4 * num_specs + 4;
9161 indices = alloca (max_indices * sizeof (indices[0]));
9162 indices[0] = indices[1] = low_index - 1;
9163 indices[2] = indices[3] = high_index + 1;
9164 num_indices = 4;
9165
9166 for (i = 0; i < n; i += 1)
9167 {
9168 switch (exp->elts[*pos].opcode)
9169 {
1fbf5ada
JB
9170 case OP_CHOICES:
9171 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9172 &num_indices, max_indices,
9173 low_index, high_index);
9174 break;
9175 case OP_POSITIONAL:
9176 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
9177 &num_indices, max_indices,
9178 low_index, high_index);
1fbf5ada
JB
9179 break;
9180 case OP_OTHERS:
9181 if (i != n-1)
9182 error (_("Misplaced 'others' clause"));
9183 aggregate_assign_others (container, lhs, exp, pos, indices,
9184 num_indices, low_index, high_index);
9185 break;
9186 default:
9187 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
9188 }
9189 }
9190
9191 return container;
9192}
9193
9194/* Assign into the component of LHS indexed by the OP_POSITIONAL
9195 construct at *POS, updating *POS past the construct, given that
9196 the positions are relative to lower bound LOW, where HIGH is the
9197 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9198 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 9199 assign_aggregate. */
52ce6436
PH
9200static void
9201aggregate_assign_positional (struct value *container,
9202 struct value *lhs, struct expression *exp,
9203 int *pos, LONGEST *indices, int *num_indices,
9204 int max_indices, LONGEST low, LONGEST high)
9205{
9206 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9207
9208 if (ind - 1 == high)
e1d5a0d2 9209 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
9210 if (ind <= high)
9211 {
9212 add_component_interval (ind, ind, indices, num_indices, max_indices);
9213 *pos += 3;
9214 assign_component (container, lhs, ind, exp, pos);
9215 }
9216 else
9217 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9218}
9219
9220/* Assign into the components of LHS indexed by the OP_CHOICES
9221 construct at *POS, updating *POS past the construct, given that
9222 the allowable indices are LOW..HIGH. Record the indices assigned
9223 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 9224 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9225static void
9226aggregate_assign_from_choices (struct value *container,
9227 struct value *lhs, struct expression *exp,
9228 int *pos, LONGEST *indices, int *num_indices,
9229 int max_indices, LONGEST low, LONGEST high)
9230{
9231 int j;
9232 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9233 int choice_pos, expr_pc;
9234 int is_array = ada_is_direct_array_type (value_type (lhs));
9235
9236 choice_pos = *pos += 3;
9237
9238 for (j = 0; j < n_choices; j += 1)
9239 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9240 expr_pc = *pos;
9241 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9242
9243 for (j = 0; j < n_choices; j += 1)
9244 {
9245 LONGEST lower, upper;
9246 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 9247
52ce6436
PH
9248 if (op == OP_DISCRETE_RANGE)
9249 {
9250 choice_pos += 1;
9251 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9252 EVAL_NORMAL));
9253 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9254 EVAL_NORMAL));
9255 }
9256 else if (is_array)
9257 {
9258 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9259 EVAL_NORMAL));
9260 upper = lower;
9261 }
9262 else
9263 {
9264 int ind;
0d5cff50 9265 const char *name;
5b4ee69b 9266
52ce6436
PH
9267 switch (op)
9268 {
9269 case OP_NAME:
9270 name = &exp->elts[choice_pos + 2].string;
9271 break;
9272 case OP_VAR_VALUE:
9273 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9274 break;
9275 default:
9276 error (_("Invalid record component association."));
9277 }
9278 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9279 ind = 0;
9280 if (! find_struct_field (name, value_type (lhs), 0,
9281 NULL, NULL, NULL, NULL, &ind))
9282 error (_("Unknown component name: %s."), name);
9283 lower = upper = ind;
9284 }
9285
9286 if (lower <= upper && (lower < low || upper > high))
9287 error (_("Index in component association out of bounds."));
9288
9289 add_component_interval (lower, upper, indices, num_indices,
9290 max_indices);
9291 while (lower <= upper)
9292 {
9293 int pos1;
5b4ee69b 9294
52ce6436
PH
9295 pos1 = expr_pc;
9296 assign_component (container, lhs, lower, exp, &pos1);
9297 lower += 1;
9298 }
9299 }
9300}
9301
9302/* Assign the value of the expression in the OP_OTHERS construct in
9303 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9304 have not been previously assigned. The index intervals already assigned
9305 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 9306 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9307static void
9308aggregate_assign_others (struct value *container,
9309 struct value *lhs, struct expression *exp,
9310 int *pos, LONGEST *indices, int num_indices,
9311 LONGEST low, LONGEST high)
9312{
9313 int i;
5ce64950 9314 int expr_pc = *pos + 1;
52ce6436
PH
9315
9316 for (i = 0; i < num_indices - 2; i += 2)
9317 {
9318 LONGEST ind;
5b4ee69b 9319
52ce6436
PH
9320 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9321 {
5ce64950 9322 int localpos;
5b4ee69b 9323
5ce64950
MS
9324 localpos = expr_pc;
9325 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
9326 }
9327 }
9328 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9329}
9330
9331/* Add the interval [LOW .. HIGH] to the sorted set of intervals
9332 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9333 modifying *SIZE as needed. It is an error if *SIZE exceeds
9334 MAX_SIZE. The resulting intervals do not overlap. */
9335static void
9336add_component_interval (LONGEST low, LONGEST high,
9337 LONGEST* indices, int *size, int max_size)
9338{
9339 int i, j;
5b4ee69b 9340
52ce6436
PH
9341 for (i = 0; i < *size; i += 2) {
9342 if (high >= indices[i] && low <= indices[i + 1])
9343 {
9344 int kh;
5b4ee69b 9345
52ce6436
PH
9346 for (kh = i + 2; kh < *size; kh += 2)
9347 if (high < indices[kh])
9348 break;
9349 if (low < indices[i])
9350 indices[i] = low;
9351 indices[i + 1] = indices[kh - 1];
9352 if (high > indices[i + 1])
9353 indices[i + 1] = high;
9354 memcpy (indices + i + 2, indices + kh, *size - kh);
9355 *size -= kh - i - 2;
9356 return;
9357 }
9358 else if (high < indices[i])
9359 break;
9360 }
9361
9362 if (*size == max_size)
9363 error (_("Internal error: miscounted aggregate components."));
9364 *size += 2;
9365 for (j = *size-1; j >= i+2; j -= 1)
9366 indices[j] = indices[j - 2];
9367 indices[i] = low;
9368 indices[i + 1] = high;
9369}
9370
6e48bd2c
JB
9371/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9372 is different. */
9373
9374static struct value *
9375ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
9376{
9377 if (type == ada_check_typedef (value_type (arg2)))
9378 return arg2;
9379
9380 if (ada_is_fixed_point_type (type))
9381 return (cast_to_fixed (type, arg2));
9382
9383 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9384 return cast_from_fixed (type, arg2);
6e48bd2c
JB
9385
9386 return value_cast (type, arg2);
9387}
9388
284614f0
JB
9389/* Evaluating Ada expressions, and printing their result.
9390 ------------------------------------------------------
9391
21649b50
JB
9392 1. Introduction:
9393 ----------------
9394
284614f0
JB
9395 We usually evaluate an Ada expression in order to print its value.
9396 We also evaluate an expression in order to print its type, which
9397 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9398 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9399 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9400 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9401 similar.
9402
9403 Evaluating expressions is a little more complicated for Ada entities
9404 than it is for entities in languages such as C. The main reason for
9405 this is that Ada provides types whose definition might be dynamic.
9406 One example of such types is variant records. Or another example
9407 would be an array whose bounds can only be known at run time.
9408
9409 The following description is a general guide as to what should be
9410 done (and what should NOT be done) in order to evaluate an expression
9411 involving such types, and when. This does not cover how the semantic
9412 information is encoded by GNAT as this is covered separatly. For the
9413 document used as the reference for the GNAT encoding, see exp_dbug.ads
9414 in the GNAT sources.
9415
9416 Ideally, we should embed each part of this description next to its
9417 associated code. Unfortunately, the amount of code is so vast right
9418 now that it's hard to see whether the code handling a particular
9419 situation might be duplicated or not. One day, when the code is
9420 cleaned up, this guide might become redundant with the comments
9421 inserted in the code, and we might want to remove it.
9422
21649b50
JB
9423 2. ``Fixing'' an Entity, the Simple Case:
9424 -----------------------------------------
9425
284614f0
JB
9426 When evaluating Ada expressions, the tricky issue is that they may
9427 reference entities whose type contents and size are not statically
9428 known. Consider for instance a variant record:
9429
9430 type Rec (Empty : Boolean := True) is record
9431 case Empty is
9432 when True => null;
9433 when False => Value : Integer;
9434 end case;
9435 end record;
9436 Yes : Rec := (Empty => False, Value => 1);
9437 No : Rec := (empty => True);
9438
9439 The size and contents of that record depends on the value of the
9440 descriminant (Rec.Empty). At this point, neither the debugging
9441 information nor the associated type structure in GDB are able to
9442 express such dynamic types. So what the debugger does is to create
9443 "fixed" versions of the type that applies to the specific object.
9444 We also informally refer to this opperation as "fixing" an object,
9445 which means creating its associated fixed type.
9446
9447 Example: when printing the value of variable "Yes" above, its fixed
9448 type would look like this:
9449
9450 type Rec is record
9451 Empty : Boolean;
9452 Value : Integer;
9453 end record;
9454
9455 On the other hand, if we printed the value of "No", its fixed type
9456 would become:
9457
9458 type Rec is record
9459 Empty : Boolean;
9460 end record;
9461
9462 Things become a little more complicated when trying to fix an entity
9463 with a dynamic type that directly contains another dynamic type,
9464 such as an array of variant records, for instance. There are
9465 two possible cases: Arrays, and records.
9466
21649b50
JB
9467 3. ``Fixing'' Arrays:
9468 ---------------------
9469
9470 The type structure in GDB describes an array in terms of its bounds,
9471 and the type of its elements. By design, all elements in the array
9472 have the same type and we cannot represent an array of variant elements
9473 using the current type structure in GDB. When fixing an array,
9474 we cannot fix the array element, as we would potentially need one
9475 fixed type per element of the array. As a result, the best we can do
9476 when fixing an array is to produce an array whose bounds and size
9477 are correct (allowing us to read it from memory), but without having
9478 touched its element type. Fixing each element will be done later,
9479 when (if) necessary.
9480
9481 Arrays are a little simpler to handle than records, because the same
9482 amount of memory is allocated for each element of the array, even if
1b536f04 9483 the amount of space actually used by each element differs from element
21649b50 9484 to element. Consider for instance the following array of type Rec:
284614f0
JB
9485
9486 type Rec_Array is array (1 .. 2) of Rec;
9487
1b536f04
JB
9488 The actual amount of memory occupied by each element might be different
9489 from element to element, depending on the value of their discriminant.
21649b50 9490 But the amount of space reserved for each element in the array remains
1b536f04 9491 fixed regardless. So we simply need to compute that size using
21649b50
JB
9492 the debugging information available, from which we can then determine
9493 the array size (we multiply the number of elements of the array by
9494 the size of each element).
9495
9496 The simplest case is when we have an array of a constrained element
9497 type. For instance, consider the following type declarations:
9498
9499 type Bounded_String (Max_Size : Integer) is
9500 Length : Integer;
9501 Buffer : String (1 .. Max_Size);
9502 end record;
9503 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9504
9505 In this case, the compiler describes the array as an array of
9506 variable-size elements (identified by its XVS suffix) for which
9507 the size can be read in the parallel XVZ variable.
9508
9509 In the case of an array of an unconstrained element type, the compiler
9510 wraps the array element inside a private PAD type. This type should not
9511 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
9512 that we also use the adjective "aligner" in our code to designate
9513 these wrapper types.
9514
1b536f04 9515 In some cases, the size allocated for each element is statically
21649b50
JB
9516 known. In that case, the PAD type already has the correct size,
9517 and the array element should remain unfixed.
9518
9519 But there are cases when this size is not statically known.
9520 For instance, assuming that "Five" is an integer variable:
284614f0
JB
9521
9522 type Dynamic is array (1 .. Five) of Integer;
9523 type Wrapper (Has_Length : Boolean := False) is record
9524 Data : Dynamic;
9525 case Has_Length is
9526 when True => Length : Integer;
9527 when False => null;
9528 end case;
9529 end record;
9530 type Wrapper_Array is array (1 .. 2) of Wrapper;
9531
9532 Hello : Wrapper_Array := (others => (Has_Length => True,
9533 Data => (others => 17),
9534 Length => 1));
9535
9536
9537 The debugging info would describe variable Hello as being an
9538 array of a PAD type. The size of that PAD type is not statically
9539 known, but can be determined using a parallel XVZ variable.
9540 In that case, a copy of the PAD type with the correct size should
9541 be used for the fixed array.
9542
21649b50
JB
9543 3. ``Fixing'' record type objects:
9544 ----------------------------------
9545
9546 Things are slightly different from arrays in the case of dynamic
284614f0
JB
9547 record types. In this case, in order to compute the associated
9548 fixed type, we need to determine the size and offset of each of
9549 its components. This, in turn, requires us to compute the fixed
9550 type of each of these components.
9551
9552 Consider for instance the example:
9553
9554 type Bounded_String (Max_Size : Natural) is record
9555 Str : String (1 .. Max_Size);
9556 Length : Natural;
9557 end record;
9558 My_String : Bounded_String (Max_Size => 10);
9559
9560 In that case, the position of field "Length" depends on the size
9561 of field Str, which itself depends on the value of the Max_Size
21649b50 9562 discriminant. In order to fix the type of variable My_String,
284614f0
JB
9563 we need to fix the type of field Str. Therefore, fixing a variant
9564 record requires us to fix each of its components.
9565
9566 However, if a component does not have a dynamic size, the component
9567 should not be fixed. In particular, fields that use a PAD type
9568 should not fixed. Here is an example where this might happen
9569 (assuming type Rec above):
9570
9571 type Container (Big : Boolean) is record
9572 First : Rec;
9573 After : Integer;
9574 case Big is
9575 when True => Another : Integer;
9576 when False => null;
9577 end case;
9578 end record;
9579 My_Container : Container := (Big => False,
9580 First => (Empty => True),
9581 After => 42);
9582
9583 In that example, the compiler creates a PAD type for component First,
9584 whose size is constant, and then positions the component After just
9585 right after it. The offset of component After is therefore constant
9586 in this case.
9587
9588 The debugger computes the position of each field based on an algorithm
9589 that uses, among other things, the actual position and size of the field
21649b50
JB
9590 preceding it. Let's now imagine that the user is trying to print
9591 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
9592 end up computing the offset of field After based on the size of the
9593 fixed version of field First. And since in our example First has
9594 only one actual field, the size of the fixed type is actually smaller
9595 than the amount of space allocated to that field, and thus we would
9596 compute the wrong offset of field After.
9597
21649b50
JB
9598 To make things more complicated, we need to watch out for dynamic
9599 components of variant records (identified by the ___XVL suffix in
9600 the component name). Even if the target type is a PAD type, the size
9601 of that type might not be statically known. So the PAD type needs
9602 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9603 we might end up with the wrong size for our component. This can be
9604 observed with the following type declarations:
284614f0
JB
9605
9606 type Octal is new Integer range 0 .. 7;
9607 type Octal_Array is array (Positive range <>) of Octal;
9608 pragma Pack (Octal_Array);
9609
9610 type Octal_Buffer (Size : Positive) is record
9611 Buffer : Octal_Array (1 .. Size);
9612 Length : Integer;
9613 end record;
9614
9615 In that case, Buffer is a PAD type whose size is unset and needs
9616 to be computed by fixing the unwrapped type.
9617
21649b50
JB
9618 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9619 ----------------------------------------------------------
9620
9621 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
9622 thus far, be actually fixed?
9623
9624 The answer is: Only when referencing that element. For instance
9625 when selecting one component of a record, this specific component
9626 should be fixed at that point in time. Or when printing the value
9627 of a record, each component should be fixed before its value gets
9628 printed. Similarly for arrays, the element of the array should be
9629 fixed when printing each element of the array, or when extracting
9630 one element out of that array. On the other hand, fixing should
9631 not be performed on the elements when taking a slice of an array!
9632
9633 Note that one of the side-effects of miscomputing the offset and
9634 size of each field is that we end up also miscomputing the size
9635 of the containing type. This can have adverse results when computing
9636 the value of an entity. GDB fetches the value of an entity based
9637 on the size of its type, and thus a wrong size causes GDB to fetch
9638 the wrong amount of memory. In the case where the computed size is
9639 too small, GDB fetches too little data to print the value of our
9640 entiry. Results in this case as unpredicatble, as we usually read
9641 past the buffer containing the data =:-o. */
9642
9643/* Implement the evaluate_exp routine in the exp_descriptor structure
9644 for the Ada language. */
9645
52ce6436 9646static struct value *
ebf56fd3 9647ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 9648 int *pos, enum noside noside)
14f9c5c9
AS
9649{
9650 enum exp_opcode op;
b5385fc0 9651 int tem;
14f9c5c9
AS
9652 int pc;
9653 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
9654 struct type *type;
52ce6436 9655 int nargs, oplen;
d2e4a39e 9656 struct value **argvec;
14f9c5c9 9657
d2e4a39e
AS
9658 pc = *pos;
9659 *pos += 1;
14f9c5c9
AS
9660 op = exp->elts[pc].opcode;
9661
d2e4a39e 9662 switch (op)
14f9c5c9
AS
9663 {
9664 default:
9665 *pos -= 1;
6e48bd2c 9666 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
9667
9668 if (noside == EVAL_NORMAL)
9669 arg1 = unwrap_value (arg1);
6e48bd2c
JB
9670
9671 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
9672 then we need to perform the conversion manually, because
9673 evaluate_subexp_standard doesn't do it. This conversion is
9674 necessary in Ada because the different kinds of float/fixed
9675 types in Ada have different representations.
9676
9677 Similarly, we need to perform the conversion from OP_LONG
9678 ourselves. */
9679 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
9680 arg1 = ada_value_cast (expect_type, arg1, noside);
9681
9682 return arg1;
4c4b4cd2
PH
9683
9684 case OP_STRING:
9685 {
76a01679 9686 struct value *result;
5b4ee69b 9687
76a01679
JB
9688 *pos -= 1;
9689 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
9690 /* The result type will have code OP_STRING, bashed there from
9691 OP_ARRAY. Bash it back. */
df407dfe
AC
9692 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
9693 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 9694 return result;
4c4b4cd2 9695 }
14f9c5c9
AS
9696
9697 case UNOP_CAST:
9698 (*pos) += 2;
9699 type = exp->elts[pc + 1].type;
9700 arg1 = evaluate_subexp (type, exp, pos, noside);
9701 if (noside == EVAL_SKIP)
4c4b4cd2 9702 goto nosideret;
6e48bd2c 9703 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
9704 return arg1;
9705
4c4b4cd2
PH
9706 case UNOP_QUAL:
9707 (*pos) += 2;
9708 type = exp->elts[pc + 1].type;
9709 return ada_evaluate_subexp (type, exp, pos, noside);
9710
14f9c5c9
AS
9711 case BINOP_ASSIGN:
9712 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
9713 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9714 {
9715 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
9716 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
9717 return arg1;
9718 return ada_value_assign (arg1, arg1);
9719 }
003f3813
JB
9720 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9721 except if the lhs of our assignment is a convenience variable.
9722 In the case of assigning to a convenience variable, the lhs
9723 should be exactly the result of the evaluation of the rhs. */
9724 type = value_type (arg1);
9725 if (VALUE_LVAL (arg1) == lval_internalvar)
9726 type = NULL;
9727 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 9728 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 9729 return arg1;
df407dfe
AC
9730 if (ada_is_fixed_point_type (value_type (arg1)))
9731 arg2 = cast_to_fixed (value_type (arg1), arg2);
9732 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 9733 error
323e0a4a 9734 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 9735 else
df407dfe 9736 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 9737 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
9738
9739 case BINOP_ADD:
9740 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9741 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9742 if (noside == EVAL_SKIP)
4c4b4cd2 9743 goto nosideret;
2ac8a782
JB
9744 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9745 return (value_from_longest
9746 (value_type (arg1),
9747 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
9748 if ((ada_is_fixed_point_type (value_type (arg1))
9749 || ada_is_fixed_point_type (value_type (arg2)))
9750 && value_type (arg1) != value_type (arg2))
323e0a4a 9751 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
9752 /* Do the addition, and cast the result to the type of the first
9753 argument. We cannot cast the result to a reference type, so if
9754 ARG1 is a reference type, find its underlying type. */
9755 type = value_type (arg1);
9756 while (TYPE_CODE (type) == TYPE_CODE_REF)
9757 type = TYPE_TARGET_TYPE (type);
f44316fa 9758 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 9759 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
9760
9761 case BINOP_SUB:
9762 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9763 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9764 if (noside == EVAL_SKIP)
4c4b4cd2 9765 goto nosideret;
2ac8a782
JB
9766 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9767 return (value_from_longest
9768 (value_type (arg1),
9769 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
9770 if ((ada_is_fixed_point_type (value_type (arg1))
9771 || ada_is_fixed_point_type (value_type (arg2)))
9772 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
9773 error (_("Operands of fixed-point subtraction "
9774 "must have the same type"));
b7789565
JB
9775 /* Do the substraction, and cast the result to the type of the first
9776 argument. We cannot cast the result to a reference type, so if
9777 ARG1 is a reference type, find its underlying type. */
9778 type = value_type (arg1);
9779 while (TYPE_CODE (type) == TYPE_CODE_REF)
9780 type = TYPE_TARGET_TYPE (type);
f44316fa 9781 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 9782 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
9783
9784 case BINOP_MUL:
9785 case BINOP_DIV:
e1578042
JB
9786 case BINOP_REM:
9787 case BINOP_MOD:
14f9c5c9
AS
9788 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9789 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9790 if (noside == EVAL_SKIP)
4c4b4cd2 9791 goto nosideret;
e1578042 9792 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
9793 {
9794 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9795 return value_zero (value_type (arg1), not_lval);
9796 }
14f9c5c9 9797 else
4c4b4cd2 9798 {
a53b7a21 9799 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 9800 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 9801 arg1 = cast_from_fixed (type, arg1);
df407dfe 9802 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9803 arg2 = cast_from_fixed (type, arg2);
f44316fa 9804 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
9805 return ada_value_binop (arg1, arg2, op);
9806 }
9807
4c4b4cd2
PH
9808 case BINOP_EQUAL:
9809 case BINOP_NOTEQUAL:
14f9c5c9 9810 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 9811 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 9812 if (noside == EVAL_SKIP)
76a01679 9813 goto nosideret;
4c4b4cd2 9814 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9815 tem = 0;
4c4b4cd2 9816 else
f44316fa
UW
9817 {
9818 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9819 tem = ada_value_equal (arg1, arg2);
9820 }
4c4b4cd2 9821 if (op == BINOP_NOTEQUAL)
76a01679 9822 tem = !tem;
fbb06eb1
UW
9823 type = language_bool_type (exp->language_defn, exp->gdbarch);
9824 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
9825
9826 case UNOP_NEG:
9827 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9828 if (noside == EVAL_SKIP)
9829 goto nosideret;
df407dfe
AC
9830 else if (ada_is_fixed_point_type (value_type (arg1)))
9831 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 9832 else
f44316fa
UW
9833 {
9834 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9835 return value_neg (arg1);
9836 }
4c4b4cd2 9837
2330c6c6
JB
9838 case BINOP_LOGICAL_AND:
9839 case BINOP_LOGICAL_OR:
9840 case UNOP_LOGICAL_NOT:
000d5124
JB
9841 {
9842 struct value *val;
9843
9844 *pos -= 1;
9845 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
9846 type = language_bool_type (exp->language_defn, exp->gdbarch);
9847 return value_cast (type, val);
000d5124 9848 }
2330c6c6
JB
9849
9850 case BINOP_BITWISE_AND:
9851 case BINOP_BITWISE_IOR:
9852 case BINOP_BITWISE_XOR:
000d5124
JB
9853 {
9854 struct value *val;
9855
9856 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
9857 *pos = pc;
9858 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
9859
9860 return value_cast (value_type (arg1), val);
9861 }
2330c6c6 9862
14f9c5c9
AS
9863 case OP_VAR_VALUE:
9864 *pos -= 1;
6799def4 9865
14f9c5c9 9866 if (noside == EVAL_SKIP)
4c4b4cd2
PH
9867 {
9868 *pos += 4;
9869 goto nosideret;
9870 }
9871 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
9872 /* Only encountered when an unresolved symbol occurs in a
9873 context other than a function call, in which case, it is
52ce6436 9874 invalid. */
323e0a4a 9875 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 9876 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
14f9c5c9 9877 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 9878 {
0c1f74cf 9879 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
9880 /* Check to see if this is a tagged type. We also need to handle
9881 the case where the type is a reference to a tagged type, but
9882 we have to be careful to exclude pointers to tagged types.
9883 The latter should be shown as usual (as a pointer), whereas
9884 a reference should mostly be transparent to the user. */
9885 if (ada_is_tagged_type (type, 0)
9886 || (TYPE_CODE(type) == TYPE_CODE_REF
9887 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0c1f74cf
JB
9888 {
9889 /* Tagged types are a little special in the fact that the real
9890 type is dynamic and can only be determined by inspecting the
9891 object's tag. This means that we need to get the object's
9892 value first (EVAL_NORMAL) and then extract the actual object
9893 type from its tag.
9894
9895 Note that we cannot skip the final step where we extract
9896 the object type from its tag, because the EVAL_NORMAL phase
9897 results in dynamic components being resolved into fixed ones.
9898 This can cause problems when trying to print the type
9899 description of tagged types whose parent has a dynamic size:
9900 We use the type name of the "_parent" component in order
9901 to print the name of the ancestor type in the type description.
9902 If that component had a dynamic size, the resolution into
9903 a fixed type would result in the loss of that type name,
9904 thus preventing us from printing the name of the ancestor
9905 type in the type description. */
9906 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
b50d69b5
JG
9907
9908 if (TYPE_CODE (type) != TYPE_CODE_REF)
9909 {
9910 struct type *actual_type;
9911
9912 actual_type = type_from_tag (ada_value_tag (arg1));
9913 if (actual_type == NULL)
9914 /* If, for some reason, we were unable to determine
9915 the actual type from the tag, then use the static
9916 approximation that we just computed as a fallback.
9917 This can happen if the debugging information is
9918 incomplete, for instance. */
9919 actual_type = type;
9920 return value_zero (actual_type, not_lval);
9921 }
9922 else
9923 {
9924 /* In the case of a ref, ada_coerce_ref takes care
9925 of determining the actual type. But the evaluation
9926 should return a ref as it should be valid to ask
9927 for its address; so rebuild a ref after coerce. */
9928 arg1 = ada_coerce_ref (arg1);
9929 return value_ref (arg1);
9930 }
0c1f74cf
JB
9931 }
9932
4c4b4cd2
PH
9933 *pos += 4;
9934 return value_zero
9935 (to_static_fixed_type
9936 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
9937 not_lval);
9938 }
d2e4a39e 9939 else
4c4b4cd2 9940 {
284614f0 9941 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
4c4b4cd2
PH
9942 return ada_to_fixed_value (arg1);
9943 }
9944
9945 case OP_FUNCALL:
9946 (*pos) += 2;
9947
9948 /* Allocate arg vector, including space for the function to be
9949 called in argvec[0] and a terminating NULL. */
9950 nargs = longest_to_int (exp->elts[pc + 1].longconst);
9951 argvec =
9952 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
9953
9954 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 9955 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 9956 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
9957 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
9958 else
9959 {
9960 for (tem = 0; tem <= nargs; tem += 1)
9961 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9962 argvec[tem] = 0;
9963
9964 if (noside == EVAL_SKIP)
9965 goto nosideret;
9966 }
9967
ad82864c
JB
9968 if (ada_is_constrained_packed_array_type
9969 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 9970 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
9971 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
9972 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
9973 /* This is a packed array that has already been fixed, and
9974 therefore already coerced to a simple array. Nothing further
9975 to do. */
9976 ;
df407dfe
AC
9977 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
9978 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
76a01679 9979 && VALUE_LVAL (argvec[0]) == lval_memory))
4c4b4cd2
PH
9980 argvec[0] = value_addr (argvec[0]);
9981
df407dfe 9982 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
9983
9984 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
9985 them. So, if this is an array typedef (encoding use for array
9986 access types encoded as fat pointers), strip it now. */
720d1a40
JB
9987 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
9988 type = ada_typedef_target_type (type);
9989
4c4b4cd2
PH
9990 if (TYPE_CODE (type) == TYPE_CODE_PTR)
9991 {
61ee279c 9992 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
9993 {
9994 case TYPE_CODE_FUNC:
61ee279c 9995 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
9996 break;
9997 case TYPE_CODE_ARRAY:
9998 break;
9999 case TYPE_CODE_STRUCT:
10000 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10001 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10002 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10003 break;
10004 default:
323e0a4a 10005 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10006 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10007 break;
10008 }
10009 }
10010
10011 switch (TYPE_CODE (type))
10012 {
10013 case TYPE_CODE_FUNC:
10014 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972
PH
10015 {
10016 struct type *rtype = TYPE_TARGET_TYPE (type);
10017
10018 if (TYPE_GNU_IFUNC (type))
10019 return allocate_value (TYPE_TARGET_TYPE (rtype));
10020 return allocate_value (rtype);
10021 }
4c4b4cd2 10022 return call_function_by_hand (argvec[0], nargs, argvec + 1);
c8ea1972
PH
10023 case TYPE_CODE_INTERNAL_FUNCTION:
10024 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10025 /* We don't know anything about what the internal
10026 function might return, but we have to return
10027 something. */
10028 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10029 not_lval);
10030 else
10031 return call_internal_function (exp->gdbarch, exp->language_defn,
10032 argvec[0], nargs, argvec + 1);
10033
4c4b4cd2
PH
10034 case TYPE_CODE_STRUCT:
10035 {
10036 int arity;
10037
4c4b4cd2
PH
10038 arity = ada_array_arity (type);
10039 type = ada_array_element_type (type, nargs);
10040 if (type == NULL)
323e0a4a 10041 error (_("cannot subscript or call a record"));
4c4b4cd2 10042 if (arity != nargs)
323e0a4a 10043 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10044 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10045 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10046 return
10047 unwrap_value (ada_value_subscript
10048 (argvec[0], nargs, argvec + 1));
10049 }
10050 case TYPE_CODE_ARRAY:
10051 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10052 {
10053 type = ada_array_element_type (type, nargs);
10054 if (type == NULL)
323e0a4a 10055 error (_("element type of array unknown"));
4c4b4cd2 10056 else
0a07e705 10057 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10058 }
10059 return
10060 unwrap_value (ada_value_subscript
10061 (ada_coerce_to_simple_array (argvec[0]),
10062 nargs, argvec + 1));
10063 case TYPE_CODE_PTR: /* Pointer to array */
10064 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10065 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10066 {
10067 type = ada_array_element_type (type, nargs);
10068 if (type == NULL)
323e0a4a 10069 error (_("element type of array unknown"));
4c4b4cd2 10070 else
0a07e705 10071 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10072 }
10073 return
10074 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
10075 nargs, argvec + 1));
10076
10077 default:
e1d5a0d2
PH
10078 error (_("Attempt to index or call something other than an "
10079 "array or function"));
4c4b4cd2
PH
10080 }
10081
10082 case TERNOP_SLICE:
10083 {
10084 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10085 struct value *low_bound_val =
10086 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
10087 struct value *high_bound_val =
10088 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10089 LONGEST low_bound;
10090 LONGEST high_bound;
5b4ee69b 10091
994b9211
AC
10092 low_bound_val = coerce_ref (low_bound_val);
10093 high_bound_val = coerce_ref (high_bound_val);
714e53ab
PH
10094 low_bound = pos_atr (low_bound_val);
10095 high_bound = pos_atr (high_bound_val);
963a6417 10096
4c4b4cd2
PH
10097 if (noside == EVAL_SKIP)
10098 goto nosideret;
10099
4c4b4cd2
PH
10100 /* If this is a reference to an aligner type, then remove all
10101 the aligners. */
df407dfe
AC
10102 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10103 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10104 TYPE_TARGET_TYPE (value_type (array)) =
10105 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 10106
ad82864c 10107 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 10108 error (_("cannot slice a packed array"));
4c4b4cd2
PH
10109
10110 /* If this is a reference to an array or an array lvalue,
10111 convert to a pointer. */
df407dfe
AC
10112 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10113 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
10114 && VALUE_LVAL (array) == lval_memory))
10115 array = value_addr (array);
10116
1265e4aa 10117 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 10118 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 10119 (value_type (array))))
0b5d8877 10120 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
10121
10122 array = ada_coerce_to_simple_array_ptr (array);
10123
714e53ab
PH
10124 /* If we have more than one level of pointer indirection,
10125 dereference the value until we get only one level. */
df407dfe
AC
10126 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10127 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
10128 == TYPE_CODE_PTR))
10129 array = value_ind (array);
10130
10131 /* Make sure we really do have an array type before going further,
10132 to avoid a SEGV when trying to get the index type or the target
10133 type later down the road if the debug info generated by
10134 the compiler is incorrect or incomplete. */
df407dfe 10135 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 10136 error (_("cannot take slice of non-array"));
714e53ab 10137
828292f2
JB
10138 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10139 == TYPE_CODE_PTR)
4c4b4cd2 10140 {
828292f2
JB
10141 struct type *type0 = ada_check_typedef (value_type (array));
10142
0b5d8877 10143 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 10144 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
10145 else
10146 {
10147 struct type *arr_type0 =
828292f2 10148 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 10149
f5938064
JG
10150 return ada_value_slice_from_ptr (array, arr_type0,
10151 longest_to_int (low_bound),
10152 longest_to_int (high_bound));
4c4b4cd2
PH
10153 }
10154 }
10155 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10156 return array;
10157 else if (high_bound < low_bound)
df407dfe 10158 return empty_array (value_type (array), low_bound);
4c4b4cd2 10159 else
529cad9c
PH
10160 return ada_value_slice (array, longest_to_int (low_bound),
10161 longest_to_int (high_bound));
4c4b4cd2 10162 }
14f9c5c9 10163
4c4b4cd2
PH
10164 case UNOP_IN_RANGE:
10165 (*pos) += 2;
10166 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 10167 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 10168
14f9c5c9 10169 if (noside == EVAL_SKIP)
4c4b4cd2 10170 goto nosideret;
14f9c5c9 10171
4c4b4cd2
PH
10172 switch (TYPE_CODE (type))
10173 {
10174 default:
e1d5a0d2
PH
10175 lim_warning (_("Membership test incompletely implemented; "
10176 "always returns true"));
fbb06eb1
UW
10177 type = language_bool_type (exp->language_defn, exp->gdbarch);
10178 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
10179
10180 case TYPE_CODE_RANGE:
030b4912
UW
10181 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10182 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
10183 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10184 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
10185 type = language_bool_type (exp->language_defn, exp->gdbarch);
10186 return
10187 value_from_longest (type,
4c4b4cd2
PH
10188 (value_less (arg1, arg3)
10189 || value_equal (arg1, arg3))
10190 && (value_less (arg2, arg1)
10191 || value_equal (arg2, arg1)));
10192 }
10193
10194 case BINOP_IN_BOUNDS:
14f9c5c9 10195 (*pos) += 2;
4c4b4cd2
PH
10196 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10197 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10198
4c4b4cd2
PH
10199 if (noside == EVAL_SKIP)
10200 goto nosideret;
14f9c5c9 10201
4c4b4cd2 10202 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
10203 {
10204 type = language_bool_type (exp->language_defn, exp->gdbarch);
10205 return value_zero (type, not_lval);
10206 }
14f9c5c9 10207
4c4b4cd2 10208 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 10209
1eea4ebd
UW
10210 type = ada_index_type (value_type (arg2), tem, "range");
10211 if (!type)
10212 type = value_type (arg1);
14f9c5c9 10213
1eea4ebd
UW
10214 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10215 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 10216
f44316fa
UW
10217 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10218 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10219 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10220 return
fbb06eb1 10221 value_from_longest (type,
4c4b4cd2
PH
10222 (value_less (arg1, arg3)
10223 || value_equal (arg1, arg3))
10224 && (value_less (arg2, arg1)
10225 || value_equal (arg2, arg1)));
10226
10227 case TERNOP_IN_RANGE:
10228 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10229 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10230 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10231
10232 if (noside == EVAL_SKIP)
10233 goto nosideret;
10234
f44316fa
UW
10235 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10236 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10237 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10238 return
fbb06eb1 10239 value_from_longest (type,
4c4b4cd2
PH
10240 (value_less (arg1, arg3)
10241 || value_equal (arg1, arg3))
10242 && (value_less (arg2, arg1)
10243 || value_equal (arg2, arg1)));
10244
10245 case OP_ATR_FIRST:
10246 case OP_ATR_LAST:
10247 case OP_ATR_LENGTH:
10248 {
76a01679 10249 struct type *type_arg;
5b4ee69b 10250
76a01679
JB
10251 if (exp->elts[*pos].opcode == OP_TYPE)
10252 {
10253 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10254 arg1 = NULL;
5bc23cb3 10255 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
10256 }
10257 else
10258 {
10259 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10260 type_arg = NULL;
10261 }
10262
10263 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 10264 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
10265 tem = longest_to_int (exp->elts[*pos + 2].longconst);
10266 *pos += 4;
10267
10268 if (noside == EVAL_SKIP)
10269 goto nosideret;
10270
10271 if (type_arg == NULL)
10272 {
10273 arg1 = ada_coerce_ref (arg1);
10274
ad82864c 10275 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
10276 arg1 = ada_coerce_to_simple_array (arg1);
10277
1eea4ebd
UW
10278 type = ada_index_type (value_type (arg1), tem,
10279 ada_attribute_name (op));
10280 if (type == NULL)
10281 type = builtin_type (exp->gdbarch)->builtin_int;
76a01679
JB
10282
10283 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 10284 return allocate_value (type);
76a01679
JB
10285
10286 switch (op)
10287 {
10288 default: /* Should never happen. */
323e0a4a 10289 error (_("unexpected attribute encountered"));
76a01679 10290 case OP_ATR_FIRST:
1eea4ebd
UW
10291 return value_from_longest
10292 (type, ada_array_bound (arg1, tem, 0));
76a01679 10293 case OP_ATR_LAST:
1eea4ebd
UW
10294 return value_from_longest
10295 (type, ada_array_bound (arg1, tem, 1));
76a01679 10296 case OP_ATR_LENGTH:
1eea4ebd
UW
10297 return value_from_longest
10298 (type, ada_array_length (arg1, tem));
76a01679
JB
10299 }
10300 }
10301 else if (discrete_type_p (type_arg))
10302 {
10303 struct type *range_type;
0d5cff50 10304 const char *name = ada_type_name (type_arg);
5b4ee69b 10305
76a01679
JB
10306 range_type = NULL;
10307 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 10308 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
10309 if (range_type == NULL)
10310 range_type = type_arg;
10311 switch (op)
10312 {
10313 default:
323e0a4a 10314 error (_("unexpected attribute encountered"));
76a01679 10315 case OP_ATR_FIRST:
690cc4eb 10316 return value_from_longest
43bbcdc2 10317 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 10318 case OP_ATR_LAST:
690cc4eb 10319 return value_from_longest
43bbcdc2 10320 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 10321 case OP_ATR_LENGTH:
323e0a4a 10322 error (_("the 'length attribute applies only to array types"));
76a01679
JB
10323 }
10324 }
10325 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 10326 error (_("unimplemented type attribute"));
76a01679
JB
10327 else
10328 {
10329 LONGEST low, high;
10330
ad82864c
JB
10331 if (ada_is_constrained_packed_array_type (type_arg))
10332 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 10333
1eea4ebd 10334 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
76a01679 10335 if (type == NULL)
1eea4ebd
UW
10336 type = builtin_type (exp->gdbarch)->builtin_int;
10337
76a01679
JB
10338 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10339 return allocate_value (type);
10340
10341 switch (op)
10342 {
10343 default:
323e0a4a 10344 error (_("unexpected attribute encountered"));
76a01679 10345 case OP_ATR_FIRST:
1eea4ebd 10346 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
10347 return value_from_longest (type, low);
10348 case OP_ATR_LAST:
1eea4ebd 10349 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10350 return value_from_longest (type, high);
10351 case OP_ATR_LENGTH:
1eea4ebd
UW
10352 low = ada_array_bound_from_type (type_arg, tem, 0);
10353 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10354 return value_from_longest (type, high - low + 1);
10355 }
10356 }
14f9c5c9
AS
10357 }
10358
4c4b4cd2
PH
10359 case OP_ATR_TAG:
10360 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10361 if (noside == EVAL_SKIP)
76a01679 10362 goto nosideret;
4c4b4cd2
PH
10363
10364 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10365 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
10366
10367 return ada_value_tag (arg1);
10368
10369 case OP_ATR_MIN:
10370 case OP_ATR_MAX:
10371 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10372 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10373 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10374 if (noside == EVAL_SKIP)
76a01679 10375 goto nosideret;
d2e4a39e 10376 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10377 return value_zero (value_type (arg1), not_lval);
14f9c5c9 10378 else
f44316fa
UW
10379 {
10380 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10381 return value_binop (arg1, arg2,
10382 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
10383 }
14f9c5c9 10384
4c4b4cd2
PH
10385 case OP_ATR_MODULUS:
10386 {
31dedfee 10387 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 10388
5b4ee69b 10389 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
10390 if (noside == EVAL_SKIP)
10391 goto nosideret;
4c4b4cd2 10392
76a01679 10393 if (!ada_is_modular_type (type_arg))
323e0a4a 10394 error (_("'modulus must be applied to modular type"));
4c4b4cd2 10395
76a01679
JB
10396 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
10397 ada_modulus (type_arg));
4c4b4cd2
PH
10398 }
10399
10400
10401 case OP_ATR_POS:
10402 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10403 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10404 if (noside == EVAL_SKIP)
76a01679 10405 goto nosideret;
3cb382c9
UW
10406 type = builtin_type (exp->gdbarch)->builtin_int;
10407 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10408 return value_zero (type, not_lval);
14f9c5c9 10409 else
3cb382c9 10410 return value_pos_atr (type, arg1);
14f9c5c9 10411
4c4b4cd2
PH
10412 case OP_ATR_SIZE:
10413 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
10414 type = value_type (arg1);
10415
10416 /* If the argument is a reference, then dereference its type, since
10417 the user is really asking for the size of the actual object,
10418 not the size of the pointer. */
10419 if (TYPE_CODE (type) == TYPE_CODE_REF)
10420 type = TYPE_TARGET_TYPE (type);
10421
4c4b4cd2 10422 if (noside == EVAL_SKIP)
76a01679 10423 goto nosideret;
4c4b4cd2 10424 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 10425 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 10426 else
22601c15 10427 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 10428 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
10429
10430 case OP_ATR_VAL:
10431 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 10432 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 10433 type = exp->elts[pc + 2].type;
14f9c5c9 10434 if (noside == EVAL_SKIP)
76a01679 10435 goto nosideret;
4c4b4cd2 10436 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10437 return value_zero (type, not_lval);
4c4b4cd2 10438 else
76a01679 10439 return value_val_atr (type, arg1);
4c4b4cd2
PH
10440
10441 case BINOP_EXP:
10442 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10443 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10444 if (noside == EVAL_SKIP)
10445 goto nosideret;
10446 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10447 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 10448 else
f44316fa
UW
10449 {
10450 /* For integer exponentiation operations,
10451 only promote the first argument. */
10452 if (is_integral_type (value_type (arg2)))
10453 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10454 else
10455 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10456
10457 return value_binop (arg1, arg2, op);
10458 }
4c4b4cd2
PH
10459
10460 case UNOP_PLUS:
10461 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10462 if (noside == EVAL_SKIP)
10463 goto nosideret;
10464 else
10465 return arg1;
10466
10467 case UNOP_ABS:
10468 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10469 if (noside == EVAL_SKIP)
10470 goto nosideret;
f44316fa 10471 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 10472 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 10473 return value_neg (arg1);
14f9c5c9 10474 else
4c4b4cd2 10475 return arg1;
14f9c5c9
AS
10476
10477 case UNOP_IND:
6b0d7253 10478 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10479 if (noside == EVAL_SKIP)
4c4b4cd2 10480 goto nosideret;
df407dfe 10481 type = ada_check_typedef (value_type (arg1));
14f9c5c9 10482 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
10483 {
10484 if (ada_is_array_descriptor_type (type))
10485 /* GDB allows dereferencing GNAT array descriptors. */
10486 {
10487 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 10488
4c4b4cd2 10489 if (arrType == NULL)
323e0a4a 10490 error (_("Attempt to dereference null array pointer."));
00a4c844 10491 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
10492 }
10493 else if (TYPE_CODE (type) == TYPE_CODE_PTR
10494 || TYPE_CODE (type) == TYPE_CODE_REF
10495 /* In C you can dereference an array to get the 1st elt. */
10496 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab
PH
10497 {
10498 type = to_static_fixed_type
10499 (ada_aligned_type
10500 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10501 check_size (type);
10502 return value_zero (type, lval_memory);
10503 }
4c4b4cd2 10504 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
10505 {
10506 /* GDB allows dereferencing an int. */
10507 if (expect_type == NULL)
10508 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10509 lval_memory);
10510 else
10511 {
10512 expect_type =
10513 to_static_fixed_type (ada_aligned_type (expect_type));
10514 return value_zero (expect_type, lval_memory);
10515 }
10516 }
4c4b4cd2 10517 else
323e0a4a 10518 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 10519 }
0963b4bd 10520 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 10521 type = ada_check_typedef (value_type (arg1));
d2e4a39e 10522
96967637
JB
10523 if (TYPE_CODE (type) == TYPE_CODE_INT)
10524 /* GDB allows dereferencing an int. If we were given
10525 the expect_type, then use that as the target type.
10526 Otherwise, assume that the target type is an int. */
10527 {
10528 if (expect_type != NULL)
10529 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10530 arg1));
10531 else
10532 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10533 (CORE_ADDR) value_as_address (arg1));
10534 }
6b0d7253 10535
4c4b4cd2
PH
10536 if (ada_is_array_descriptor_type (type))
10537 /* GDB allows dereferencing GNAT array descriptors. */
10538 return ada_coerce_to_simple_array (arg1);
14f9c5c9 10539 else
4c4b4cd2 10540 return ada_value_ind (arg1);
14f9c5c9
AS
10541
10542 case STRUCTOP_STRUCT:
10543 tem = longest_to_int (exp->elts[pc + 1].longconst);
10544 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
10545 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10546 if (noside == EVAL_SKIP)
4c4b4cd2 10547 goto nosideret;
14f9c5c9 10548 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10549 {
df407dfe 10550 struct type *type1 = value_type (arg1);
5b4ee69b 10551
76a01679
JB
10552 if (ada_is_tagged_type (type1, 1))
10553 {
10554 type = ada_lookup_struct_elt_type (type1,
10555 &exp->elts[pc + 2].string,
10556 1, 1, NULL);
10557 if (type == NULL)
10558 /* In this case, we assume that the field COULD exist
10559 in some extension of the type. Return an object of
10560 "type" void, which will match any formal
0963b4bd 10561 (see ada_type_match). */
30b15541
UW
10562 return value_zero (builtin_type (exp->gdbarch)->builtin_void,
10563 lval_memory);
76a01679
JB
10564 }
10565 else
10566 type =
10567 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
10568 0, NULL);
10569
10570 return value_zero (ada_aligned_type (type), lval_memory);
10571 }
14f9c5c9 10572 else
284614f0
JB
10573 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
10574 arg1 = unwrap_value (arg1);
10575 return ada_to_fixed_value (arg1);
10576
14f9c5c9 10577 case OP_TYPE:
4c4b4cd2
PH
10578 /* The value is not supposed to be used. This is here to make it
10579 easier to accommodate expressions that contain types. */
14f9c5c9
AS
10580 (*pos) += 2;
10581 if (noside == EVAL_SKIP)
4c4b4cd2 10582 goto nosideret;
14f9c5c9 10583 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 10584 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 10585 else
323e0a4a 10586 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
10587
10588 case OP_AGGREGATE:
10589 case OP_CHOICES:
10590 case OP_OTHERS:
10591 case OP_DISCRETE_RANGE:
10592 case OP_POSITIONAL:
10593 case OP_NAME:
10594 if (noside == EVAL_NORMAL)
10595 switch (op)
10596 {
10597 case OP_NAME:
10598 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 10599 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
10600 case OP_AGGREGATE:
10601 error (_("Aggregates only allowed on the right of an assignment"));
10602 default:
0963b4bd
MS
10603 internal_error (__FILE__, __LINE__,
10604 _("aggregate apparently mangled"));
52ce6436
PH
10605 }
10606
10607 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10608 *pos += oplen - 1;
10609 for (tem = 0; tem < nargs; tem += 1)
10610 ada_evaluate_subexp (NULL, exp, pos, noside);
10611 goto nosideret;
14f9c5c9
AS
10612 }
10613
10614nosideret:
22601c15 10615 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
14f9c5c9 10616}
14f9c5c9 10617\f
d2e4a39e 10618
4c4b4cd2 10619 /* Fixed point */
14f9c5c9
AS
10620
10621/* If TYPE encodes an Ada fixed-point type, return the suffix of the
10622 type name that encodes the 'small and 'delta information.
4c4b4cd2 10623 Otherwise, return NULL. */
14f9c5c9 10624
d2e4a39e 10625static const char *
ebf56fd3 10626fixed_type_info (struct type *type)
14f9c5c9 10627{
d2e4a39e 10628 const char *name = ada_type_name (type);
14f9c5c9
AS
10629 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
10630
d2e4a39e
AS
10631 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
10632 {
14f9c5c9 10633 const char *tail = strstr (name, "___XF_");
5b4ee69b 10634
14f9c5c9 10635 if (tail == NULL)
4c4b4cd2 10636 return NULL;
d2e4a39e 10637 else
4c4b4cd2 10638 return tail + 5;
14f9c5c9
AS
10639 }
10640 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
10641 return fixed_type_info (TYPE_TARGET_TYPE (type));
10642 else
10643 return NULL;
10644}
10645
4c4b4cd2 10646/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
10647
10648int
ebf56fd3 10649ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
10650{
10651 return fixed_type_info (type) != NULL;
10652}
10653
4c4b4cd2
PH
10654/* Return non-zero iff TYPE represents a System.Address type. */
10655
10656int
10657ada_is_system_address_type (struct type *type)
10658{
10659 return (TYPE_NAME (type)
10660 && strcmp (TYPE_NAME (type), "system__address") == 0);
10661}
10662
14f9c5c9
AS
10663/* Assuming that TYPE is the representation of an Ada fixed-point
10664 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 10665 delta cannot be determined. */
14f9c5c9
AS
10666
10667DOUBLEST
ebf56fd3 10668ada_delta (struct type *type)
14f9c5c9
AS
10669{
10670 const char *encoding = fixed_type_info (type);
facc390f 10671 DOUBLEST num, den;
14f9c5c9 10672
facc390f
JB
10673 /* Strictly speaking, num and den are encoded as integer. However,
10674 they may not fit into a long, and they will have to be converted
10675 to DOUBLEST anyway. So scan them as DOUBLEST. */
10676 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10677 &num, &den) < 2)
14f9c5c9 10678 return -1.0;
d2e4a39e 10679 else
facc390f 10680 return num / den;
14f9c5c9
AS
10681}
10682
10683/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 10684 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
10685
10686static DOUBLEST
ebf56fd3 10687scaling_factor (struct type *type)
14f9c5c9
AS
10688{
10689 const char *encoding = fixed_type_info (type);
facc390f 10690 DOUBLEST num0, den0, num1, den1;
14f9c5c9 10691 int n;
d2e4a39e 10692
facc390f
JB
10693 /* Strictly speaking, num's and den's are encoded as integer. However,
10694 they may not fit into a long, and they will have to be converted
10695 to DOUBLEST anyway. So scan them as DOUBLEST. */
10696 n = sscanf (encoding,
10697 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
10698 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10699 &num0, &den0, &num1, &den1);
14f9c5c9
AS
10700
10701 if (n < 2)
10702 return 1.0;
10703 else if (n == 4)
facc390f 10704 return num1 / den1;
d2e4a39e 10705 else
facc390f 10706 return num0 / den0;
14f9c5c9
AS
10707}
10708
10709
10710/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 10711 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
10712
10713DOUBLEST
ebf56fd3 10714ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 10715{
d2e4a39e 10716 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
10717}
10718
4c4b4cd2
PH
10719/* The representation of a fixed-point value of type TYPE
10720 corresponding to the value X. */
14f9c5c9
AS
10721
10722LONGEST
ebf56fd3 10723ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
10724{
10725 return (LONGEST) (x / scaling_factor (type) + 0.5);
10726}
10727
14f9c5c9 10728\f
d2e4a39e 10729
4c4b4cd2 10730 /* Range types */
14f9c5c9
AS
10731
10732/* Scan STR beginning at position K for a discriminant name, and
10733 return the value of that discriminant field of DVAL in *PX. If
10734 PNEW_K is not null, put the position of the character beyond the
10735 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 10736 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
10737
10738static int
07d8f827 10739scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
76a01679 10740 int *pnew_k)
14f9c5c9
AS
10741{
10742 static char *bound_buffer = NULL;
10743 static size_t bound_buffer_len = 0;
10744 char *bound;
10745 char *pend;
d2e4a39e 10746 struct value *bound_val;
14f9c5c9
AS
10747
10748 if (dval == NULL || str == NULL || str[k] == '\0')
10749 return 0;
10750
d2e4a39e 10751 pend = strstr (str + k, "__");
14f9c5c9
AS
10752 if (pend == NULL)
10753 {
d2e4a39e 10754 bound = str + k;
14f9c5c9
AS
10755 k += strlen (bound);
10756 }
d2e4a39e 10757 else
14f9c5c9 10758 {
d2e4a39e 10759 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
14f9c5c9 10760 bound = bound_buffer;
d2e4a39e
AS
10761 strncpy (bound_buffer, str + k, pend - (str + k));
10762 bound[pend - (str + k)] = '\0';
10763 k = pend - str;
14f9c5c9 10764 }
d2e4a39e 10765
df407dfe 10766 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
10767 if (bound_val == NULL)
10768 return 0;
10769
10770 *px = value_as_long (bound_val);
10771 if (pnew_k != NULL)
10772 *pnew_k = k;
10773 return 1;
10774}
10775
10776/* Value of variable named NAME in the current environment. If
10777 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
10778 otherwise causes an error with message ERR_MSG. */
10779
d2e4a39e
AS
10780static struct value *
10781get_var_value (char *name, char *err_msg)
14f9c5c9 10782{
4c4b4cd2 10783 struct ada_symbol_info *syms;
14f9c5c9
AS
10784 int nsyms;
10785
4c4b4cd2 10786 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
4eeaa230 10787 &syms);
14f9c5c9
AS
10788
10789 if (nsyms != 1)
10790 {
10791 if (err_msg == NULL)
4c4b4cd2 10792 return 0;
14f9c5c9 10793 else
8a3fe4f8 10794 error (("%s"), err_msg);
14f9c5c9
AS
10795 }
10796
4c4b4cd2 10797 return value_of_variable (syms[0].sym, syms[0].block);
14f9c5c9 10798}
d2e4a39e 10799
14f9c5c9 10800/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
10801 no such variable found, returns 0, and sets *FLAG to 0. If
10802 successful, sets *FLAG to 1. */
10803
14f9c5c9 10804LONGEST
4c4b4cd2 10805get_int_var_value (char *name, int *flag)
14f9c5c9 10806{
4c4b4cd2 10807 struct value *var_val = get_var_value (name, 0);
d2e4a39e 10808
14f9c5c9
AS
10809 if (var_val == 0)
10810 {
10811 if (flag != NULL)
4c4b4cd2 10812 *flag = 0;
14f9c5c9
AS
10813 return 0;
10814 }
10815 else
10816 {
10817 if (flag != NULL)
4c4b4cd2 10818 *flag = 1;
14f9c5c9
AS
10819 return value_as_long (var_val);
10820 }
10821}
d2e4a39e 10822
14f9c5c9
AS
10823
10824/* Return a range type whose base type is that of the range type named
10825 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 10826 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
10827 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
10828 corresponding range type from debug information; fall back to using it
10829 if symbol lookup fails. If a new type must be created, allocate it
10830 like ORIG_TYPE was. The bounds information, in general, is encoded
10831 in NAME, the base type given in the named range type. */
14f9c5c9 10832
d2e4a39e 10833static struct type *
28c85d6c 10834to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 10835{
0d5cff50 10836 const char *name;
14f9c5c9 10837 struct type *base_type;
d2e4a39e 10838 char *subtype_info;
14f9c5c9 10839
28c85d6c
JB
10840 gdb_assert (raw_type != NULL);
10841 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 10842
1ce677a4 10843 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
10844 base_type = TYPE_TARGET_TYPE (raw_type);
10845 else
10846 base_type = raw_type;
10847
28c85d6c 10848 name = TYPE_NAME (raw_type);
14f9c5c9
AS
10849 subtype_info = strstr (name, "___XD");
10850 if (subtype_info == NULL)
690cc4eb 10851 {
43bbcdc2
PH
10852 LONGEST L = ada_discrete_type_low_bound (raw_type);
10853 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 10854
690cc4eb
PH
10855 if (L < INT_MIN || U > INT_MAX)
10856 return raw_type;
10857 else
28c85d6c 10858 return create_range_type (alloc_type_copy (raw_type), raw_type,
43bbcdc2
PH
10859 ada_discrete_type_low_bound (raw_type),
10860 ada_discrete_type_high_bound (raw_type));
690cc4eb 10861 }
14f9c5c9
AS
10862 else
10863 {
10864 static char *name_buf = NULL;
10865 static size_t name_len = 0;
10866 int prefix_len = subtype_info - name;
10867 LONGEST L, U;
10868 struct type *type;
10869 char *bounds_str;
10870 int n;
10871
10872 GROW_VECT (name_buf, name_len, prefix_len + 5);
10873 strncpy (name_buf, name, prefix_len);
10874 name_buf[prefix_len] = '\0';
10875
10876 subtype_info += 5;
10877 bounds_str = strchr (subtype_info, '_');
10878 n = 1;
10879
d2e4a39e 10880 if (*subtype_info == 'L')
4c4b4cd2
PH
10881 {
10882 if (!ada_scan_number (bounds_str, n, &L, &n)
10883 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
10884 return raw_type;
10885 if (bounds_str[n] == '_')
10886 n += 2;
0963b4bd 10887 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
10888 n += 1;
10889 subtype_info += 1;
10890 }
d2e4a39e 10891 else
4c4b4cd2
PH
10892 {
10893 int ok;
5b4ee69b 10894
4c4b4cd2
PH
10895 strcpy (name_buf + prefix_len, "___L");
10896 L = get_int_var_value (name_buf, &ok);
10897 if (!ok)
10898 {
323e0a4a 10899 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
10900 L = 1;
10901 }
10902 }
14f9c5c9 10903
d2e4a39e 10904 if (*subtype_info == 'U')
4c4b4cd2
PH
10905 {
10906 if (!ada_scan_number (bounds_str, n, &U, &n)
10907 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
10908 return raw_type;
10909 }
d2e4a39e 10910 else
4c4b4cd2
PH
10911 {
10912 int ok;
5b4ee69b 10913
4c4b4cd2
PH
10914 strcpy (name_buf + prefix_len, "___U");
10915 U = get_int_var_value (name_buf, &ok);
10916 if (!ok)
10917 {
323e0a4a 10918 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
10919 U = L;
10920 }
10921 }
14f9c5c9 10922
28c85d6c 10923 type = create_range_type (alloc_type_copy (raw_type), base_type, L, U);
d2e4a39e 10924 TYPE_NAME (type) = name;
14f9c5c9
AS
10925 return type;
10926 }
10927}
10928
4c4b4cd2
PH
10929/* True iff NAME is the name of a range type. */
10930
14f9c5c9 10931int
d2e4a39e 10932ada_is_range_type_name (const char *name)
14f9c5c9
AS
10933{
10934 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 10935}
14f9c5c9 10936\f
d2e4a39e 10937
4c4b4cd2
PH
10938 /* Modular types */
10939
10940/* True iff TYPE is an Ada modular type. */
14f9c5c9 10941
14f9c5c9 10942int
d2e4a39e 10943ada_is_modular_type (struct type *type)
14f9c5c9 10944{
18af8284 10945 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
10946
10947 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 10948 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 10949 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
10950}
10951
4c4b4cd2
PH
10952/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
10953
61ee279c 10954ULONGEST
0056e4d5 10955ada_modulus (struct type *type)
14f9c5c9 10956{
43bbcdc2 10957 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 10958}
d2e4a39e 10959\f
f7f9143b
JB
10960
10961/* Ada exception catchpoint support:
10962 ---------------------------------
10963
10964 We support 3 kinds of exception catchpoints:
10965 . catchpoints on Ada exceptions
10966 . catchpoints on unhandled Ada exceptions
10967 . catchpoints on failed assertions
10968
10969 Exceptions raised during failed assertions, or unhandled exceptions
10970 could perfectly be caught with the general catchpoint on Ada exceptions.
10971 However, we can easily differentiate these two special cases, and having
10972 the option to distinguish these two cases from the rest can be useful
10973 to zero-in on certain situations.
10974
10975 Exception catchpoints are a specialized form of breakpoint,
10976 since they rely on inserting breakpoints inside known routines
10977 of the GNAT runtime. The implementation therefore uses a standard
10978 breakpoint structure of the BP_BREAKPOINT type, but with its own set
10979 of breakpoint_ops.
10980
0259addd
JB
10981 Support in the runtime for exception catchpoints have been changed
10982 a few times already, and these changes affect the implementation
10983 of these catchpoints. In order to be able to support several
10984 variants of the runtime, we use a sniffer that will determine
28010a5d 10985 the runtime variant used by the program being debugged. */
f7f9143b 10986
3d0b0fa3
JB
10987/* Ada's standard exceptions. */
10988
10989static char *standard_exc[] = {
10990 "constraint_error",
10991 "program_error",
10992 "storage_error",
10993 "tasking_error"
10994};
10995
0259addd
JB
10996typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
10997
10998/* A structure that describes how to support exception catchpoints
10999 for a given executable. */
11000
11001struct exception_support_info
11002{
11003 /* The name of the symbol to break on in order to insert
11004 a catchpoint on exceptions. */
11005 const char *catch_exception_sym;
11006
11007 /* The name of the symbol to break on in order to insert
11008 a catchpoint on unhandled exceptions. */
11009 const char *catch_exception_unhandled_sym;
11010
11011 /* The name of the symbol to break on in order to insert
11012 a catchpoint on failed assertions. */
11013 const char *catch_assert_sym;
11014
11015 /* Assuming that the inferior just triggered an unhandled exception
11016 catchpoint, this function is responsible for returning the address
11017 in inferior memory where the name of that exception is stored.
11018 Return zero if the address could not be computed. */
11019 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11020};
11021
11022static CORE_ADDR ada_unhandled_exception_name_addr (void);
11023static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11024
11025/* The following exception support info structure describes how to
11026 implement exception catchpoints with the latest version of the
11027 Ada runtime (as of 2007-03-06). */
11028
11029static const struct exception_support_info default_exception_support_info =
11030{
11031 "__gnat_debug_raise_exception", /* catch_exception_sym */
11032 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11033 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11034 ada_unhandled_exception_name_addr
11035};
11036
11037/* The following exception support info structure describes how to
11038 implement exception catchpoints with a slightly older version
11039 of the Ada runtime. */
11040
11041static const struct exception_support_info exception_support_info_fallback =
11042{
11043 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11044 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11045 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11046 ada_unhandled_exception_name_addr_from_raise
11047};
11048
f17011e0
JB
11049/* Return nonzero if we can detect the exception support routines
11050 described in EINFO.
11051
11052 This function errors out if an abnormal situation is detected
11053 (for instance, if we find the exception support routines, but
11054 that support is found to be incomplete). */
11055
11056static int
11057ada_has_this_exception_support (const struct exception_support_info *einfo)
11058{
11059 struct symbol *sym;
11060
11061 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11062 that should be compiled with debugging information. As a result, we
11063 expect to find that symbol in the symtabs. */
11064
11065 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11066 if (sym == NULL)
a6af7abe
JB
11067 {
11068 /* Perhaps we did not find our symbol because the Ada runtime was
11069 compiled without debugging info, or simply stripped of it.
11070 It happens on some GNU/Linux distributions for instance, where
11071 users have to install a separate debug package in order to get
11072 the runtime's debugging info. In that situation, let the user
11073 know why we cannot insert an Ada exception catchpoint.
11074
11075 Note: Just for the purpose of inserting our Ada exception
11076 catchpoint, we could rely purely on the associated minimal symbol.
11077 But we would be operating in degraded mode anyway, since we are
11078 still lacking the debugging info needed later on to extract
11079 the name of the exception being raised (this name is printed in
11080 the catchpoint message, and is also used when trying to catch
11081 a specific exception). We do not handle this case for now. */
1c8e84b0
JB
11082 struct minimal_symbol *msym
11083 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11084
11085 if (msym && MSYMBOL_TYPE (msym) != mst_solib_trampoline)
a6af7abe
JB
11086 error (_("Your Ada runtime appears to be missing some debugging "
11087 "information.\nCannot insert Ada exception catchpoint "
11088 "in this configuration."));
11089
11090 return 0;
11091 }
f17011e0
JB
11092
11093 /* Make sure that the symbol we found corresponds to a function. */
11094
11095 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11096 error (_("Symbol \"%s\" is not a function (class = %d)"),
11097 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11098
11099 return 1;
11100}
11101
0259addd
JB
11102/* Inspect the Ada runtime and determine which exception info structure
11103 should be used to provide support for exception catchpoints.
11104
3eecfa55
JB
11105 This function will always set the per-inferior exception_info,
11106 or raise an error. */
0259addd
JB
11107
11108static void
11109ada_exception_support_info_sniffer (void)
11110{
3eecfa55 11111 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
11112
11113 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 11114 if (data->exception_info != NULL)
0259addd
JB
11115 return;
11116
11117 /* Check the latest (default) exception support info. */
f17011e0 11118 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 11119 {
3eecfa55 11120 data->exception_info = &default_exception_support_info;
0259addd
JB
11121 return;
11122 }
11123
11124 /* Try our fallback exception suport info. */
f17011e0 11125 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 11126 {
3eecfa55 11127 data->exception_info = &exception_support_info_fallback;
0259addd
JB
11128 return;
11129 }
11130
11131 /* Sometimes, it is normal for us to not be able to find the routine
11132 we are looking for. This happens when the program is linked with
11133 the shared version of the GNAT runtime, and the program has not been
11134 started yet. Inform the user of these two possible causes if
11135 applicable. */
11136
ccefe4c4 11137 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
11138 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11139
11140 /* If the symbol does not exist, then check that the program is
11141 already started, to make sure that shared libraries have been
11142 loaded. If it is not started, this may mean that the symbol is
11143 in a shared library. */
11144
11145 if (ptid_get_pid (inferior_ptid) == 0)
11146 error (_("Unable to insert catchpoint. Try to start the program first."));
11147
11148 /* At this point, we know that we are debugging an Ada program and
11149 that the inferior has been started, but we still are not able to
0963b4bd 11150 find the run-time symbols. That can mean that we are in
0259addd
JB
11151 configurable run time mode, or that a-except as been optimized
11152 out by the linker... In any case, at this point it is not worth
11153 supporting this feature. */
11154
7dda8cff 11155 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
11156}
11157
f7f9143b
JB
11158/* True iff FRAME is very likely to be that of a function that is
11159 part of the runtime system. This is all very heuristic, but is
11160 intended to be used as advice as to what frames are uninteresting
11161 to most users. */
11162
11163static int
11164is_known_support_routine (struct frame_info *frame)
11165{
4ed6b5be 11166 struct symtab_and_line sal;
55b87a52 11167 char *func_name;
692465f1 11168 enum language func_lang;
f7f9143b 11169 int i;
f35a17b5 11170 const char *fullname;
f7f9143b 11171
4ed6b5be
JB
11172 /* If this code does not have any debugging information (no symtab),
11173 This cannot be any user code. */
f7f9143b 11174
4ed6b5be 11175 find_frame_sal (frame, &sal);
f7f9143b
JB
11176 if (sal.symtab == NULL)
11177 return 1;
11178
4ed6b5be
JB
11179 /* If there is a symtab, but the associated source file cannot be
11180 located, then assume this is not user code: Selecting a frame
11181 for which we cannot display the code would not be very helpful
11182 for the user. This should also take care of case such as VxWorks
11183 where the kernel has some debugging info provided for a few units. */
f7f9143b 11184
f35a17b5
JK
11185 fullname = symtab_to_fullname (sal.symtab);
11186 if (access (fullname, R_OK) != 0)
f7f9143b
JB
11187 return 1;
11188
4ed6b5be
JB
11189 /* Check the unit filename againt the Ada runtime file naming.
11190 We also check the name of the objfile against the name of some
11191 known system libraries that sometimes come with debugging info
11192 too. */
11193
f7f9143b
JB
11194 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11195 {
11196 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 11197 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 11198 return 1;
4ed6b5be 11199 if (sal.symtab->objfile != NULL
4262abfb 11200 && re_exec (objfile_name (sal.symtab->objfile)))
4ed6b5be 11201 return 1;
f7f9143b
JB
11202 }
11203
4ed6b5be 11204 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 11205
e9e07ba6 11206 find_frame_funname (frame, &func_name, &func_lang, NULL);
f7f9143b
JB
11207 if (func_name == NULL)
11208 return 1;
11209
11210 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11211 {
11212 re_comp (known_auxiliary_function_name_patterns[i]);
11213 if (re_exec (func_name))
55b87a52
KS
11214 {
11215 xfree (func_name);
11216 return 1;
11217 }
f7f9143b
JB
11218 }
11219
55b87a52 11220 xfree (func_name);
f7f9143b
JB
11221 return 0;
11222}
11223
11224/* Find the first frame that contains debugging information and that is not
11225 part of the Ada run-time, starting from FI and moving upward. */
11226
0ef643c8 11227void
f7f9143b
JB
11228ada_find_printable_frame (struct frame_info *fi)
11229{
11230 for (; fi != NULL; fi = get_prev_frame (fi))
11231 {
11232 if (!is_known_support_routine (fi))
11233 {
11234 select_frame (fi);
11235 break;
11236 }
11237 }
11238
11239}
11240
11241/* Assuming that the inferior just triggered an unhandled exception
11242 catchpoint, return the address in inferior memory where the name
11243 of the exception is stored.
11244
11245 Return zero if the address could not be computed. */
11246
11247static CORE_ADDR
11248ada_unhandled_exception_name_addr (void)
0259addd
JB
11249{
11250 return parse_and_eval_address ("e.full_name");
11251}
11252
11253/* Same as ada_unhandled_exception_name_addr, except that this function
11254 should be used when the inferior uses an older version of the runtime,
11255 where the exception name needs to be extracted from a specific frame
11256 several frames up in the callstack. */
11257
11258static CORE_ADDR
11259ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
11260{
11261 int frame_level;
11262 struct frame_info *fi;
3eecfa55 11263 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
55b87a52 11264 struct cleanup *old_chain;
f7f9143b
JB
11265
11266 /* To determine the name of this exception, we need to select
11267 the frame corresponding to RAISE_SYM_NAME. This frame is
11268 at least 3 levels up, so we simply skip the first 3 frames
11269 without checking the name of their associated function. */
11270 fi = get_current_frame ();
11271 for (frame_level = 0; frame_level < 3; frame_level += 1)
11272 if (fi != NULL)
11273 fi = get_prev_frame (fi);
11274
55b87a52 11275 old_chain = make_cleanup (null_cleanup, NULL);
f7f9143b
JB
11276 while (fi != NULL)
11277 {
55b87a52 11278 char *func_name;
692465f1
JB
11279 enum language func_lang;
11280
e9e07ba6 11281 find_frame_funname (fi, &func_name, &func_lang, NULL);
55b87a52
KS
11282 if (func_name != NULL)
11283 {
11284 make_cleanup (xfree, func_name);
11285
11286 if (strcmp (func_name,
11287 data->exception_info->catch_exception_sym) == 0)
11288 break; /* We found the frame we were looking for... */
11289 fi = get_prev_frame (fi);
11290 }
f7f9143b 11291 }
55b87a52 11292 do_cleanups (old_chain);
f7f9143b
JB
11293
11294 if (fi == NULL)
11295 return 0;
11296
11297 select_frame (fi);
11298 return parse_and_eval_address ("id.full_name");
11299}
11300
11301/* Assuming the inferior just triggered an Ada exception catchpoint
11302 (of any type), return the address in inferior memory where the name
11303 of the exception is stored, if applicable.
11304
11305 Return zero if the address could not be computed, or if not relevant. */
11306
11307static CORE_ADDR
761269c8 11308ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11309 struct breakpoint *b)
11310{
3eecfa55
JB
11311 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11312
f7f9143b
JB
11313 switch (ex)
11314 {
761269c8 11315 case ada_catch_exception:
f7f9143b
JB
11316 return (parse_and_eval_address ("e.full_name"));
11317 break;
11318
761269c8 11319 case ada_catch_exception_unhandled:
3eecfa55 11320 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
11321 break;
11322
761269c8 11323 case ada_catch_assert:
f7f9143b
JB
11324 return 0; /* Exception name is not relevant in this case. */
11325 break;
11326
11327 default:
11328 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11329 break;
11330 }
11331
11332 return 0; /* Should never be reached. */
11333}
11334
11335/* Same as ada_exception_name_addr_1, except that it intercepts and contains
11336 any error that ada_exception_name_addr_1 might cause to be thrown.
11337 When an error is intercepted, a warning with the error message is printed,
11338 and zero is returned. */
11339
11340static CORE_ADDR
761269c8 11341ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11342 struct breakpoint *b)
11343{
bfd189b1 11344 volatile struct gdb_exception e;
f7f9143b
JB
11345 CORE_ADDR result = 0;
11346
11347 TRY_CATCH (e, RETURN_MASK_ERROR)
11348 {
11349 result = ada_exception_name_addr_1 (ex, b);
11350 }
11351
11352 if (e.reason < 0)
11353 {
11354 warning (_("failed to get exception name: %s"), e.message);
11355 return 0;
11356 }
11357
11358 return result;
11359}
11360
28010a5d
PA
11361static char *ada_exception_catchpoint_cond_string (const char *excep_string);
11362
11363/* Ada catchpoints.
11364
11365 In the case of catchpoints on Ada exceptions, the catchpoint will
11366 stop the target on every exception the program throws. When a user
11367 specifies the name of a specific exception, we translate this
11368 request into a condition expression (in text form), and then parse
11369 it into an expression stored in each of the catchpoint's locations.
11370 We then use this condition to check whether the exception that was
11371 raised is the one the user is interested in. If not, then the
11372 target is resumed again. We store the name of the requested
11373 exception, in order to be able to re-set the condition expression
11374 when symbols change. */
11375
11376/* An instance of this type is used to represent an Ada catchpoint
11377 breakpoint location. It includes a "struct bp_location" as a kind
11378 of base class; users downcast to "struct bp_location *" when
11379 needed. */
11380
11381struct ada_catchpoint_location
11382{
11383 /* The base class. */
11384 struct bp_location base;
11385
11386 /* The condition that checks whether the exception that was raised
11387 is the specific exception the user specified on catchpoint
11388 creation. */
11389 struct expression *excep_cond_expr;
11390};
11391
11392/* Implement the DTOR method in the bp_location_ops structure for all
11393 Ada exception catchpoint kinds. */
11394
11395static void
11396ada_catchpoint_location_dtor (struct bp_location *bl)
11397{
11398 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
11399
11400 xfree (al->excep_cond_expr);
11401}
11402
11403/* The vtable to be used in Ada catchpoint locations. */
11404
11405static const struct bp_location_ops ada_catchpoint_location_ops =
11406{
11407 ada_catchpoint_location_dtor
11408};
11409
11410/* An instance of this type is used to represent an Ada catchpoint.
11411 It includes a "struct breakpoint" as a kind of base class; users
11412 downcast to "struct breakpoint *" when needed. */
11413
11414struct ada_catchpoint
11415{
11416 /* The base class. */
11417 struct breakpoint base;
11418
11419 /* The name of the specific exception the user specified. */
11420 char *excep_string;
11421};
11422
11423/* Parse the exception condition string in the context of each of the
11424 catchpoint's locations, and store them for later evaluation. */
11425
11426static void
11427create_excep_cond_exprs (struct ada_catchpoint *c)
11428{
11429 struct cleanup *old_chain;
11430 struct bp_location *bl;
11431 char *cond_string;
11432
11433 /* Nothing to do if there's no specific exception to catch. */
11434 if (c->excep_string == NULL)
11435 return;
11436
11437 /* Same if there are no locations... */
11438 if (c->base.loc == NULL)
11439 return;
11440
11441 /* Compute the condition expression in text form, from the specific
11442 expection we want to catch. */
11443 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
11444 old_chain = make_cleanup (xfree, cond_string);
11445
11446 /* Iterate over all the catchpoint's locations, and parse an
11447 expression for each. */
11448 for (bl = c->base.loc; bl != NULL; bl = bl->next)
11449 {
11450 struct ada_catchpoint_location *ada_loc
11451 = (struct ada_catchpoint_location *) bl;
11452 struct expression *exp = NULL;
11453
11454 if (!bl->shlib_disabled)
11455 {
11456 volatile struct gdb_exception e;
bbc13ae3 11457 const char *s;
28010a5d
PA
11458
11459 s = cond_string;
11460 TRY_CATCH (e, RETURN_MASK_ERROR)
11461 {
1bb9788d
TT
11462 exp = parse_exp_1 (&s, bl->address,
11463 block_for_pc (bl->address), 0);
28010a5d
PA
11464 }
11465 if (e.reason < 0)
849f2b52
JB
11466 {
11467 warning (_("failed to reevaluate internal exception condition "
11468 "for catchpoint %d: %s"),
11469 c->base.number, e.message);
11470 /* There is a bug in GCC on sparc-solaris when building with
11471 optimization which causes EXP to change unexpectedly
11472 (http://gcc.gnu.org/bugzilla/show_bug.cgi?id=56982).
11473 The problem should be fixed starting with GCC 4.9.
11474 In the meantime, work around it by forcing EXP back
11475 to NULL. */
11476 exp = NULL;
11477 }
28010a5d
PA
11478 }
11479
11480 ada_loc->excep_cond_expr = exp;
11481 }
11482
11483 do_cleanups (old_chain);
11484}
11485
11486/* Implement the DTOR method in the breakpoint_ops structure for all
11487 exception catchpoint kinds. */
11488
11489static void
761269c8 11490dtor_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
11491{
11492 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11493
11494 xfree (c->excep_string);
348d480f 11495
2060206e 11496 bkpt_breakpoint_ops.dtor (b);
28010a5d
PA
11497}
11498
11499/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11500 structure for all exception catchpoint kinds. */
11501
11502static struct bp_location *
761269c8 11503allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
11504 struct breakpoint *self)
11505{
11506 struct ada_catchpoint_location *loc;
11507
11508 loc = XNEW (struct ada_catchpoint_location);
11509 init_bp_location (&loc->base, &ada_catchpoint_location_ops, self);
11510 loc->excep_cond_expr = NULL;
11511 return &loc->base;
11512}
11513
11514/* Implement the RE_SET method in the breakpoint_ops structure for all
11515 exception catchpoint kinds. */
11516
11517static void
761269c8 11518re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
11519{
11520 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11521
11522 /* Call the base class's method. This updates the catchpoint's
11523 locations. */
2060206e 11524 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
11525
11526 /* Reparse the exception conditional expressions. One for each
11527 location. */
11528 create_excep_cond_exprs (c);
11529}
11530
11531/* Returns true if we should stop for this breakpoint hit. If the
11532 user specified a specific exception, we only want to cause a stop
11533 if the program thrown that exception. */
11534
11535static int
11536should_stop_exception (const struct bp_location *bl)
11537{
11538 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11539 const struct ada_catchpoint_location *ada_loc
11540 = (const struct ada_catchpoint_location *) bl;
11541 volatile struct gdb_exception ex;
11542 int stop;
11543
11544 /* With no specific exception, should always stop. */
11545 if (c->excep_string == NULL)
11546 return 1;
11547
11548 if (ada_loc->excep_cond_expr == NULL)
11549 {
11550 /* We will have a NULL expression if back when we were creating
11551 the expressions, this location's had failed to parse. */
11552 return 1;
11553 }
11554
11555 stop = 1;
11556 TRY_CATCH (ex, RETURN_MASK_ALL)
11557 {
11558 struct value *mark;
11559
11560 mark = value_mark ();
11561 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr));
11562 value_free_to_mark (mark);
11563 }
11564 if (ex.reason < 0)
11565 exception_fprintf (gdb_stderr, ex,
11566 _("Error in testing exception condition:\n"));
11567 return stop;
11568}
11569
11570/* Implement the CHECK_STATUS method in the breakpoint_ops structure
11571 for all exception catchpoint kinds. */
11572
11573static void
761269c8 11574check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
11575{
11576 bs->stop = should_stop_exception (bs->bp_location_at);
11577}
11578
f7f9143b
JB
11579/* Implement the PRINT_IT method in the breakpoint_ops structure
11580 for all exception catchpoint kinds. */
11581
11582static enum print_stop_action
761269c8 11583print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 11584{
79a45e25 11585 struct ui_out *uiout = current_uiout;
348d480f
PA
11586 struct breakpoint *b = bs->breakpoint_at;
11587
956a9fb9 11588 annotate_catchpoint (b->number);
f7f9143b 11589
956a9fb9 11590 if (ui_out_is_mi_like_p (uiout))
f7f9143b 11591 {
956a9fb9
JB
11592 ui_out_field_string (uiout, "reason",
11593 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11594 ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition));
f7f9143b
JB
11595 }
11596
00eb2c4a
JB
11597 ui_out_text (uiout,
11598 b->disposition == disp_del ? "\nTemporary catchpoint "
11599 : "\nCatchpoint ");
956a9fb9
JB
11600 ui_out_field_int (uiout, "bkptno", b->number);
11601 ui_out_text (uiout, ", ");
f7f9143b 11602
f7f9143b
JB
11603 switch (ex)
11604 {
761269c8
JB
11605 case ada_catch_exception:
11606 case ada_catch_exception_unhandled:
956a9fb9
JB
11607 {
11608 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
11609 char exception_name[256];
11610
11611 if (addr != 0)
11612 {
c714b426
PA
11613 read_memory (addr, (gdb_byte *) exception_name,
11614 sizeof (exception_name) - 1);
956a9fb9
JB
11615 exception_name [sizeof (exception_name) - 1] = '\0';
11616 }
11617 else
11618 {
11619 /* For some reason, we were unable to read the exception
11620 name. This could happen if the Runtime was compiled
11621 without debugging info, for instance. In that case,
11622 just replace the exception name by the generic string
11623 "exception" - it will read as "an exception" in the
11624 notification we are about to print. */
967cff16 11625 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
11626 }
11627 /* In the case of unhandled exception breakpoints, we print
11628 the exception name as "unhandled EXCEPTION_NAME", to make
11629 it clearer to the user which kind of catchpoint just got
11630 hit. We used ui_out_text to make sure that this extra
11631 info does not pollute the exception name in the MI case. */
761269c8 11632 if (ex == ada_catch_exception_unhandled)
956a9fb9
JB
11633 ui_out_text (uiout, "unhandled ");
11634 ui_out_field_string (uiout, "exception-name", exception_name);
11635 }
11636 break;
761269c8 11637 case ada_catch_assert:
956a9fb9
JB
11638 /* In this case, the name of the exception is not really
11639 important. Just print "failed assertion" to make it clearer
11640 that his program just hit an assertion-failure catchpoint.
11641 We used ui_out_text because this info does not belong in
11642 the MI output. */
11643 ui_out_text (uiout, "failed assertion");
11644 break;
f7f9143b 11645 }
956a9fb9
JB
11646 ui_out_text (uiout, " at ");
11647 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
11648
11649 return PRINT_SRC_AND_LOC;
11650}
11651
11652/* Implement the PRINT_ONE method in the breakpoint_ops structure
11653 for all exception catchpoint kinds. */
11654
11655static void
761269c8 11656print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 11657 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11658{
79a45e25 11659 struct ui_out *uiout = current_uiout;
28010a5d 11660 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
11661 struct value_print_options opts;
11662
11663 get_user_print_options (&opts);
11664 if (opts.addressprint)
f7f9143b
JB
11665 {
11666 annotate_field (4);
5af949e3 11667 ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
11668 }
11669
11670 annotate_field (5);
a6d9a66e 11671 *last_loc = b->loc;
f7f9143b
JB
11672 switch (ex)
11673 {
761269c8 11674 case ada_catch_exception:
28010a5d 11675 if (c->excep_string != NULL)
f7f9143b 11676 {
28010a5d
PA
11677 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11678
f7f9143b
JB
11679 ui_out_field_string (uiout, "what", msg);
11680 xfree (msg);
11681 }
11682 else
11683 ui_out_field_string (uiout, "what", "all Ada exceptions");
11684
11685 break;
11686
761269c8 11687 case ada_catch_exception_unhandled:
f7f9143b
JB
11688 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
11689 break;
11690
761269c8 11691 case ada_catch_assert:
f7f9143b
JB
11692 ui_out_field_string (uiout, "what", "failed Ada assertions");
11693 break;
11694
11695 default:
11696 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11697 break;
11698 }
11699}
11700
11701/* Implement the PRINT_MENTION method in the breakpoint_ops structure
11702 for all exception catchpoint kinds. */
11703
11704static void
761269c8 11705print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11706 struct breakpoint *b)
11707{
28010a5d 11708 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 11709 struct ui_out *uiout = current_uiout;
28010a5d 11710
00eb2c4a
JB
11711 ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ")
11712 : _("Catchpoint "));
11713 ui_out_field_int (uiout, "bkptno", b->number);
11714 ui_out_text (uiout, ": ");
11715
f7f9143b
JB
11716 switch (ex)
11717 {
761269c8 11718 case ada_catch_exception:
28010a5d 11719 if (c->excep_string != NULL)
00eb2c4a
JB
11720 {
11721 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11722 struct cleanup *old_chain = make_cleanup (xfree, info);
11723
11724 ui_out_text (uiout, info);
11725 do_cleanups (old_chain);
11726 }
f7f9143b 11727 else
00eb2c4a 11728 ui_out_text (uiout, _("all Ada exceptions"));
f7f9143b
JB
11729 break;
11730
761269c8 11731 case ada_catch_exception_unhandled:
00eb2c4a 11732 ui_out_text (uiout, _("unhandled Ada exceptions"));
f7f9143b
JB
11733 break;
11734
761269c8 11735 case ada_catch_assert:
00eb2c4a 11736 ui_out_text (uiout, _("failed Ada assertions"));
f7f9143b
JB
11737 break;
11738
11739 default:
11740 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11741 break;
11742 }
11743}
11744
6149aea9
PA
11745/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
11746 for all exception catchpoint kinds. */
11747
11748static void
761269c8 11749print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
11750 struct breakpoint *b, struct ui_file *fp)
11751{
28010a5d
PA
11752 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11753
6149aea9
PA
11754 switch (ex)
11755 {
761269c8 11756 case ada_catch_exception:
6149aea9 11757 fprintf_filtered (fp, "catch exception");
28010a5d
PA
11758 if (c->excep_string != NULL)
11759 fprintf_filtered (fp, " %s", c->excep_string);
6149aea9
PA
11760 break;
11761
761269c8 11762 case ada_catch_exception_unhandled:
78076abc 11763 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
11764 break;
11765
761269c8 11766 case ada_catch_assert:
6149aea9
PA
11767 fprintf_filtered (fp, "catch assert");
11768 break;
11769
11770 default:
11771 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11772 }
d9b3f62e 11773 print_recreate_thread (b, fp);
6149aea9
PA
11774}
11775
f7f9143b
JB
11776/* Virtual table for "catch exception" breakpoints. */
11777
28010a5d
PA
11778static void
11779dtor_catch_exception (struct breakpoint *b)
11780{
761269c8 11781 dtor_exception (ada_catch_exception, b);
28010a5d
PA
11782}
11783
11784static struct bp_location *
11785allocate_location_catch_exception (struct breakpoint *self)
11786{
761269c8 11787 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
11788}
11789
11790static void
11791re_set_catch_exception (struct breakpoint *b)
11792{
761269c8 11793 re_set_exception (ada_catch_exception, b);
28010a5d
PA
11794}
11795
11796static void
11797check_status_catch_exception (bpstat bs)
11798{
761269c8 11799 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
11800}
11801
f7f9143b 11802static enum print_stop_action
348d480f 11803print_it_catch_exception (bpstat bs)
f7f9143b 11804{
761269c8 11805 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
11806}
11807
11808static void
a6d9a66e 11809print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11810{
761269c8 11811 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
11812}
11813
11814static void
11815print_mention_catch_exception (struct breakpoint *b)
11816{
761269c8 11817 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
11818}
11819
6149aea9
PA
11820static void
11821print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
11822{
761269c8 11823 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
11824}
11825
2060206e 11826static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
11827
11828/* Virtual table for "catch exception unhandled" breakpoints. */
11829
28010a5d
PA
11830static void
11831dtor_catch_exception_unhandled (struct breakpoint *b)
11832{
761269c8 11833 dtor_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
11834}
11835
11836static struct bp_location *
11837allocate_location_catch_exception_unhandled (struct breakpoint *self)
11838{
761269c8 11839 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
11840}
11841
11842static void
11843re_set_catch_exception_unhandled (struct breakpoint *b)
11844{
761269c8 11845 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
11846}
11847
11848static void
11849check_status_catch_exception_unhandled (bpstat bs)
11850{
761269c8 11851 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
11852}
11853
f7f9143b 11854static enum print_stop_action
348d480f 11855print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 11856{
761269c8 11857 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
11858}
11859
11860static void
a6d9a66e
UW
11861print_one_catch_exception_unhandled (struct breakpoint *b,
11862 struct bp_location **last_loc)
f7f9143b 11863{
761269c8 11864 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
11865}
11866
11867static void
11868print_mention_catch_exception_unhandled (struct breakpoint *b)
11869{
761269c8 11870 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
11871}
11872
6149aea9
PA
11873static void
11874print_recreate_catch_exception_unhandled (struct breakpoint *b,
11875 struct ui_file *fp)
11876{
761269c8 11877 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
11878}
11879
2060206e 11880static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
11881
11882/* Virtual table for "catch assert" breakpoints. */
11883
28010a5d
PA
11884static void
11885dtor_catch_assert (struct breakpoint *b)
11886{
761269c8 11887 dtor_exception (ada_catch_assert, b);
28010a5d
PA
11888}
11889
11890static struct bp_location *
11891allocate_location_catch_assert (struct breakpoint *self)
11892{
761269c8 11893 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
11894}
11895
11896static void
11897re_set_catch_assert (struct breakpoint *b)
11898{
761269c8 11899 re_set_exception (ada_catch_assert, b);
28010a5d
PA
11900}
11901
11902static void
11903check_status_catch_assert (bpstat bs)
11904{
761269c8 11905 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
11906}
11907
f7f9143b 11908static enum print_stop_action
348d480f 11909print_it_catch_assert (bpstat bs)
f7f9143b 11910{
761269c8 11911 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
11912}
11913
11914static void
a6d9a66e 11915print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11916{
761269c8 11917 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
11918}
11919
11920static void
11921print_mention_catch_assert (struct breakpoint *b)
11922{
761269c8 11923 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
11924}
11925
6149aea9
PA
11926static void
11927print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
11928{
761269c8 11929 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
11930}
11931
2060206e 11932static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 11933
f7f9143b
JB
11934/* Return a newly allocated copy of the first space-separated token
11935 in ARGSP, and then adjust ARGSP to point immediately after that
11936 token.
11937
11938 Return NULL if ARGPS does not contain any more tokens. */
11939
11940static char *
11941ada_get_next_arg (char **argsp)
11942{
11943 char *args = *argsp;
11944 char *end;
11945 char *result;
11946
0fcd72ba 11947 args = skip_spaces (args);
f7f9143b
JB
11948 if (args[0] == '\0')
11949 return NULL; /* No more arguments. */
11950
11951 /* Find the end of the current argument. */
11952
0fcd72ba 11953 end = skip_to_space (args);
f7f9143b
JB
11954
11955 /* Adjust ARGSP to point to the start of the next argument. */
11956
11957 *argsp = end;
11958
11959 /* Make a copy of the current argument and return it. */
11960
11961 result = xmalloc (end - args + 1);
11962 strncpy (result, args, end - args);
11963 result[end - args] = '\0';
11964
11965 return result;
11966}
11967
11968/* Split the arguments specified in a "catch exception" command.
11969 Set EX to the appropriate catchpoint type.
28010a5d 11970 Set EXCEP_STRING to the name of the specific exception if
5845583d
JB
11971 specified by the user.
11972 If a condition is found at the end of the arguments, the condition
11973 expression is stored in COND_STRING (memory must be deallocated
11974 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
11975
11976static void
11977catch_ada_exception_command_split (char *args,
761269c8 11978 enum ada_exception_catchpoint_kind *ex,
5845583d
JB
11979 char **excep_string,
11980 char **cond_string)
f7f9143b
JB
11981{
11982 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
11983 char *exception_name;
5845583d 11984 char *cond = NULL;
f7f9143b
JB
11985
11986 exception_name = ada_get_next_arg (&args);
5845583d
JB
11987 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
11988 {
11989 /* This is not an exception name; this is the start of a condition
11990 expression for a catchpoint on all exceptions. So, "un-get"
11991 this token, and set exception_name to NULL. */
11992 xfree (exception_name);
11993 exception_name = NULL;
11994 args -= 2;
11995 }
f7f9143b
JB
11996 make_cleanup (xfree, exception_name);
11997
5845583d 11998 /* Check to see if we have a condition. */
f7f9143b 11999
0fcd72ba 12000 args = skip_spaces (args);
5845583d
JB
12001 if (strncmp (args, "if", 2) == 0
12002 && (isspace (args[2]) || args[2] == '\0'))
12003 {
12004 args += 2;
12005 args = skip_spaces (args);
12006
12007 if (args[0] == '\0')
12008 error (_("Condition missing after `if' keyword"));
12009 cond = xstrdup (args);
12010 make_cleanup (xfree, cond);
12011
12012 args += strlen (args);
12013 }
12014
12015 /* Check that we do not have any more arguments. Anything else
12016 is unexpected. */
f7f9143b
JB
12017
12018 if (args[0] != '\0')
12019 error (_("Junk at end of expression"));
12020
12021 discard_cleanups (old_chain);
12022
12023 if (exception_name == NULL)
12024 {
12025 /* Catch all exceptions. */
761269c8 12026 *ex = ada_catch_exception;
28010a5d 12027 *excep_string = NULL;
f7f9143b
JB
12028 }
12029 else if (strcmp (exception_name, "unhandled") == 0)
12030 {
12031 /* Catch unhandled exceptions. */
761269c8 12032 *ex = ada_catch_exception_unhandled;
28010a5d 12033 *excep_string = NULL;
f7f9143b
JB
12034 }
12035 else
12036 {
12037 /* Catch a specific exception. */
761269c8 12038 *ex = ada_catch_exception;
28010a5d 12039 *excep_string = exception_name;
f7f9143b 12040 }
5845583d 12041 *cond_string = cond;
f7f9143b
JB
12042}
12043
12044/* Return the name of the symbol on which we should break in order to
12045 implement a catchpoint of the EX kind. */
12046
12047static const char *
761269c8 12048ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 12049{
3eecfa55
JB
12050 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12051
12052 gdb_assert (data->exception_info != NULL);
0259addd 12053
f7f9143b
JB
12054 switch (ex)
12055 {
761269c8 12056 case ada_catch_exception:
3eecfa55 12057 return (data->exception_info->catch_exception_sym);
f7f9143b 12058 break;
761269c8 12059 case ada_catch_exception_unhandled:
3eecfa55 12060 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 12061 break;
761269c8 12062 case ada_catch_assert:
3eecfa55 12063 return (data->exception_info->catch_assert_sym);
f7f9143b
JB
12064 break;
12065 default:
12066 internal_error (__FILE__, __LINE__,
12067 _("unexpected catchpoint kind (%d)"), ex);
12068 }
12069}
12070
12071/* Return the breakpoint ops "virtual table" used for catchpoints
12072 of the EX kind. */
12073
c0a91b2b 12074static const struct breakpoint_ops *
761269c8 12075ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
12076{
12077 switch (ex)
12078 {
761269c8 12079 case ada_catch_exception:
f7f9143b
JB
12080 return (&catch_exception_breakpoint_ops);
12081 break;
761269c8 12082 case ada_catch_exception_unhandled:
f7f9143b
JB
12083 return (&catch_exception_unhandled_breakpoint_ops);
12084 break;
761269c8 12085 case ada_catch_assert:
f7f9143b
JB
12086 return (&catch_assert_breakpoint_ops);
12087 break;
12088 default:
12089 internal_error (__FILE__, __LINE__,
12090 _("unexpected catchpoint kind (%d)"), ex);
12091 }
12092}
12093
12094/* Return the condition that will be used to match the current exception
12095 being raised with the exception that the user wants to catch. This
12096 assumes that this condition is used when the inferior just triggered
12097 an exception catchpoint.
12098
12099 The string returned is a newly allocated string that needs to be
12100 deallocated later. */
12101
12102static char *
28010a5d 12103ada_exception_catchpoint_cond_string (const char *excep_string)
f7f9143b 12104{
3d0b0fa3
JB
12105 int i;
12106
0963b4bd 12107 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 12108 runtime units that have been compiled without debugging info; if
28010a5d 12109 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
12110 exception (e.g. "constraint_error") then, during the evaluation
12111 of the condition expression, the symbol lookup on this name would
0963b4bd 12112 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
12113 may then be set only on user-defined exceptions which have the
12114 same not-fully-qualified name (e.g. my_package.constraint_error).
12115
12116 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 12117 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
12118 exception constraint_error" is rewritten into "catch exception
12119 standard.constraint_error".
12120
12121 If an exception named contraint_error is defined in another package of
12122 the inferior program, then the only way to specify this exception as a
12123 breakpoint condition is to use its fully-qualified named:
12124 e.g. my_package.constraint_error. */
12125
12126 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12127 {
28010a5d 12128 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3
JB
12129 {
12130 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
28010a5d 12131 excep_string);
3d0b0fa3
JB
12132 }
12133 }
28010a5d 12134 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
f7f9143b
JB
12135}
12136
12137/* Return the symtab_and_line that should be used to insert an exception
12138 catchpoint of the TYPE kind.
12139
28010a5d
PA
12140 EXCEP_STRING should contain the name of a specific exception that
12141 the catchpoint should catch, or NULL otherwise.
f7f9143b 12142
28010a5d
PA
12143 ADDR_STRING returns the name of the function where the real
12144 breakpoint that implements the catchpoints is set, depending on the
12145 type of catchpoint we need to create. */
f7f9143b
JB
12146
12147static struct symtab_and_line
761269c8 12148ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
c0a91b2b 12149 char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
12150{
12151 const char *sym_name;
12152 struct symbol *sym;
f7f9143b 12153
0259addd
JB
12154 /* First, find out which exception support info to use. */
12155 ada_exception_support_info_sniffer ();
12156
12157 /* Then lookup the function on which we will break in order to catch
f7f9143b 12158 the Ada exceptions requested by the user. */
f7f9143b
JB
12159 sym_name = ada_exception_sym_name (ex);
12160 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12161
f17011e0
JB
12162 /* We can assume that SYM is not NULL at this stage. If the symbol
12163 did not exist, ada_exception_support_info_sniffer would have
12164 raised an exception.
f7f9143b 12165
f17011e0
JB
12166 Also, ada_exception_support_info_sniffer should have already
12167 verified that SYM is a function symbol. */
12168 gdb_assert (sym != NULL);
12169 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
12170
12171 /* Set ADDR_STRING. */
f7f9143b
JB
12172 *addr_string = xstrdup (sym_name);
12173
f7f9143b 12174 /* Set OPS. */
4b9eee8c 12175 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 12176
f17011e0 12177 return find_function_start_sal (sym, 1);
f7f9143b
JB
12178}
12179
b4a5b78b 12180/* Create an Ada exception catchpoint.
f7f9143b 12181
b4a5b78b 12182 EX_KIND is the kind of exception catchpoint to be created.
5845583d 12183
2df4d1d5
JB
12184 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
12185 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12186 of the exception to which this catchpoint applies. When not NULL,
12187 the string must be allocated on the heap, and its deallocation
12188 is no longer the responsibility of the caller.
12189
12190 COND_STRING, if not NULL, is the catchpoint condition. This string
12191 must be allocated on the heap, and its deallocation is no longer
12192 the responsibility of the caller.
f7f9143b 12193
b4a5b78b
JB
12194 TEMPFLAG, if nonzero, means that the underlying breakpoint
12195 should be temporary.
28010a5d 12196
b4a5b78b 12197 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 12198
349774ef 12199void
28010a5d 12200create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 12201 enum ada_exception_catchpoint_kind ex_kind,
28010a5d 12202 char *excep_string,
5845583d 12203 char *cond_string,
28010a5d 12204 int tempflag,
349774ef 12205 int disabled,
28010a5d
PA
12206 int from_tty)
12207{
12208 struct ada_catchpoint *c;
b4a5b78b
JB
12209 char *addr_string = NULL;
12210 const struct breakpoint_ops *ops = NULL;
12211 struct symtab_and_line sal
12212 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
28010a5d
PA
12213
12214 c = XNEW (struct ada_catchpoint);
12215 init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string,
349774ef 12216 ops, tempflag, disabled, from_tty);
28010a5d
PA
12217 c->excep_string = excep_string;
12218 create_excep_cond_exprs (c);
5845583d
JB
12219 if (cond_string != NULL)
12220 set_breakpoint_condition (&c->base, cond_string, from_tty);
3ea46bff 12221 install_breakpoint (0, &c->base, 1);
f7f9143b
JB
12222}
12223
9ac4176b
PA
12224/* Implement the "catch exception" command. */
12225
12226static void
12227catch_ada_exception_command (char *arg, int from_tty,
12228 struct cmd_list_element *command)
12229{
12230 struct gdbarch *gdbarch = get_current_arch ();
12231 int tempflag;
761269c8 12232 enum ada_exception_catchpoint_kind ex_kind;
28010a5d 12233 char *excep_string = NULL;
5845583d 12234 char *cond_string = NULL;
9ac4176b
PA
12235
12236 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12237
12238 if (!arg)
12239 arg = "";
b4a5b78b
JB
12240 catch_ada_exception_command_split (arg, &ex_kind, &excep_string,
12241 &cond_string);
12242 create_ada_exception_catchpoint (gdbarch, ex_kind,
12243 excep_string, cond_string,
349774ef
JB
12244 tempflag, 1 /* enabled */,
12245 from_tty);
9ac4176b
PA
12246}
12247
b4a5b78b 12248/* Split the arguments specified in a "catch assert" command.
5845583d 12249
b4a5b78b
JB
12250 ARGS contains the command's arguments (or the empty string if
12251 no arguments were passed).
5845583d
JB
12252
12253 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 12254 (the memory needs to be deallocated after use). */
5845583d 12255
b4a5b78b
JB
12256static void
12257catch_ada_assert_command_split (char *args, char **cond_string)
f7f9143b 12258{
5845583d 12259 args = skip_spaces (args);
f7f9143b 12260
5845583d
JB
12261 /* Check whether a condition was provided. */
12262 if (strncmp (args, "if", 2) == 0
12263 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 12264 {
5845583d 12265 args += 2;
0fcd72ba 12266 args = skip_spaces (args);
5845583d
JB
12267 if (args[0] == '\0')
12268 error (_("condition missing after `if' keyword"));
12269 *cond_string = xstrdup (args);
f7f9143b
JB
12270 }
12271
5845583d
JB
12272 /* Otherwise, there should be no other argument at the end of
12273 the command. */
12274 else if (args[0] != '\0')
12275 error (_("Junk at end of arguments."));
f7f9143b
JB
12276}
12277
9ac4176b
PA
12278/* Implement the "catch assert" command. */
12279
12280static void
12281catch_assert_command (char *arg, int from_tty,
12282 struct cmd_list_element *command)
12283{
12284 struct gdbarch *gdbarch = get_current_arch ();
12285 int tempflag;
5845583d 12286 char *cond_string = NULL;
9ac4176b
PA
12287
12288 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12289
12290 if (!arg)
12291 arg = "";
b4a5b78b 12292 catch_ada_assert_command_split (arg, &cond_string);
761269c8 12293 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
b4a5b78b 12294 NULL, cond_string,
349774ef
JB
12295 tempflag, 1 /* enabled */,
12296 from_tty);
9ac4176b 12297}
778865d3
JB
12298
12299/* Return non-zero if the symbol SYM is an Ada exception object. */
12300
12301static int
12302ada_is_exception_sym (struct symbol *sym)
12303{
12304 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
12305
12306 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
12307 && SYMBOL_CLASS (sym) != LOC_BLOCK
12308 && SYMBOL_CLASS (sym) != LOC_CONST
12309 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
12310 && type_name != NULL && strcmp (type_name, "exception") == 0);
12311}
12312
12313/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12314 Ada exception object. This matches all exceptions except the ones
12315 defined by the Ada language. */
12316
12317static int
12318ada_is_non_standard_exception_sym (struct symbol *sym)
12319{
12320 int i;
12321
12322 if (!ada_is_exception_sym (sym))
12323 return 0;
12324
12325 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12326 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
12327 return 0; /* A standard exception. */
12328
12329 /* Numeric_Error is also a standard exception, so exclude it.
12330 See the STANDARD_EXC description for more details as to why
12331 this exception is not listed in that array. */
12332 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
12333 return 0;
12334
12335 return 1;
12336}
12337
12338/* A helper function for qsort, comparing two struct ada_exc_info
12339 objects.
12340
12341 The comparison is determined first by exception name, and then
12342 by exception address. */
12343
12344static int
12345compare_ada_exception_info (const void *a, const void *b)
12346{
12347 const struct ada_exc_info *exc_a = (struct ada_exc_info *) a;
12348 const struct ada_exc_info *exc_b = (struct ada_exc_info *) b;
12349 int result;
12350
12351 result = strcmp (exc_a->name, exc_b->name);
12352 if (result != 0)
12353 return result;
12354
12355 if (exc_a->addr < exc_b->addr)
12356 return -1;
12357 if (exc_a->addr > exc_b->addr)
12358 return 1;
12359
12360 return 0;
12361}
12362
12363/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12364 routine, but keeping the first SKIP elements untouched.
12365
12366 All duplicates are also removed. */
12367
12368static void
12369sort_remove_dups_ada_exceptions_list (VEC(ada_exc_info) **exceptions,
12370 int skip)
12371{
12372 struct ada_exc_info *to_sort
12373 = VEC_address (ada_exc_info, *exceptions) + skip;
12374 int to_sort_len
12375 = VEC_length (ada_exc_info, *exceptions) - skip;
12376 int i, j;
12377
12378 qsort (to_sort, to_sort_len, sizeof (struct ada_exc_info),
12379 compare_ada_exception_info);
12380
12381 for (i = 1, j = 1; i < to_sort_len; i++)
12382 if (compare_ada_exception_info (&to_sort[i], &to_sort[j - 1]) != 0)
12383 to_sort[j++] = to_sort[i];
12384 to_sort_len = j;
12385 VEC_truncate(ada_exc_info, *exceptions, skip + to_sort_len);
12386}
12387
12388/* A function intended as the "name_matcher" callback in the struct
12389 quick_symbol_functions' expand_symtabs_matching method.
12390
12391 SEARCH_NAME is the symbol's search name.
12392
12393 If USER_DATA is not NULL, it is a pointer to a regext_t object
12394 used to match the symbol (by natural name). Otherwise, when USER_DATA
12395 is null, no filtering is performed, and all symbols are a positive
12396 match. */
12397
12398static int
12399ada_exc_search_name_matches (const char *search_name, void *user_data)
12400{
12401 regex_t *preg = user_data;
12402
12403 if (preg == NULL)
12404 return 1;
12405
12406 /* In Ada, the symbol "search name" is a linkage name, whereas
12407 the regular expression used to do the matching refers to
12408 the natural name. So match against the decoded name. */
12409 return (regexec (preg, ada_decode (search_name), 0, NULL, 0) == 0);
12410}
12411
12412/* Add all exceptions defined by the Ada standard whose name match
12413 a regular expression.
12414
12415 If PREG is not NULL, then this regexp_t object is used to
12416 perform the symbol name matching. Otherwise, no name-based
12417 filtering is performed.
12418
12419 EXCEPTIONS is a vector of exceptions to which matching exceptions
12420 gets pushed. */
12421
12422static void
12423ada_add_standard_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
12424{
12425 int i;
12426
12427 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12428 {
12429 if (preg == NULL
12430 || regexec (preg, standard_exc[i], 0, NULL, 0) == 0)
12431 {
12432 struct bound_minimal_symbol msymbol
12433 = ada_lookup_simple_minsym (standard_exc[i]);
12434
12435 if (msymbol.minsym != NULL)
12436 {
12437 struct ada_exc_info info
12438 = {standard_exc[i], SYMBOL_VALUE_ADDRESS (msymbol.minsym)};
12439
12440 VEC_safe_push (ada_exc_info, *exceptions, &info);
12441 }
12442 }
12443 }
12444}
12445
12446/* Add all Ada exceptions defined locally and accessible from the given
12447 FRAME.
12448
12449 If PREG is not NULL, then this regexp_t object is used to
12450 perform the symbol name matching. Otherwise, no name-based
12451 filtering is performed.
12452
12453 EXCEPTIONS is a vector of exceptions to which matching exceptions
12454 gets pushed. */
12455
12456static void
12457ada_add_exceptions_from_frame (regex_t *preg, struct frame_info *frame,
12458 VEC(ada_exc_info) **exceptions)
12459{
12460 struct block *block = get_frame_block (frame, 0);
12461
12462 while (block != 0)
12463 {
12464 struct block_iterator iter;
12465 struct symbol *sym;
12466
12467 ALL_BLOCK_SYMBOLS (block, iter, sym)
12468 {
12469 switch (SYMBOL_CLASS (sym))
12470 {
12471 case LOC_TYPEDEF:
12472 case LOC_BLOCK:
12473 case LOC_CONST:
12474 break;
12475 default:
12476 if (ada_is_exception_sym (sym))
12477 {
12478 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
12479 SYMBOL_VALUE_ADDRESS (sym)};
12480
12481 VEC_safe_push (ada_exc_info, *exceptions, &info);
12482 }
12483 }
12484 }
12485 if (BLOCK_FUNCTION (block) != NULL)
12486 break;
12487 block = BLOCK_SUPERBLOCK (block);
12488 }
12489}
12490
12491/* Add all exceptions defined globally whose name name match
12492 a regular expression, excluding standard exceptions.
12493
12494 The reason we exclude standard exceptions is that they need
12495 to be handled separately: Standard exceptions are defined inside
12496 a runtime unit which is normally not compiled with debugging info,
12497 and thus usually do not show up in our symbol search. However,
12498 if the unit was in fact built with debugging info, we need to
12499 exclude them because they would duplicate the entry we found
12500 during the special loop that specifically searches for those
12501 standard exceptions.
12502
12503 If PREG is not NULL, then this regexp_t object is used to
12504 perform the symbol name matching. Otherwise, no name-based
12505 filtering is performed.
12506
12507 EXCEPTIONS is a vector of exceptions to which matching exceptions
12508 gets pushed. */
12509
12510static void
12511ada_add_global_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
12512{
12513 struct objfile *objfile;
12514 struct symtab *s;
12515
bb4142cf
DE
12516 expand_symtabs_matching (NULL, ada_exc_search_name_matches,
12517 VARIABLES_DOMAIN, preg);
778865d3
JB
12518
12519 ALL_PRIMARY_SYMTABS (objfile, s)
12520 {
12521 struct blockvector *bv = BLOCKVECTOR (s);
12522 int i;
12523
12524 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
12525 {
12526 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
12527 struct block_iterator iter;
12528 struct symbol *sym;
12529
12530 ALL_BLOCK_SYMBOLS (b, iter, sym)
12531 if (ada_is_non_standard_exception_sym (sym)
12532 && (preg == NULL
12533 || regexec (preg, SYMBOL_NATURAL_NAME (sym),
12534 0, NULL, 0) == 0))
12535 {
12536 struct ada_exc_info info
12537 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
12538
12539 VEC_safe_push (ada_exc_info, *exceptions, &info);
12540 }
12541 }
12542 }
12543}
12544
12545/* Implements ada_exceptions_list with the regular expression passed
12546 as a regex_t, rather than a string.
12547
12548 If not NULL, PREG is used to filter out exceptions whose names
12549 do not match. Otherwise, all exceptions are listed. */
12550
12551static VEC(ada_exc_info) *
12552ada_exceptions_list_1 (regex_t *preg)
12553{
12554 VEC(ada_exc_info) *result = NULL;
12555 struct cleanup *old_chain
12556 = make_cleanup (VEC_cleanup (ada_exc_info), &result);
12557 int prev_len;
12558
12559 /* First, list the known standard exceptions. These exceptions
12560 need to be handled separately, as they are usually defined in
12561 runtime units that have been compiled without debugging info. */
12562
12563 ada_add_standard_exceptions (preg, &result);
12564
12565 /* Next, find all exceptions whose scope is local and accessible
12566 from the currently selected frame. */
12567
12568 if (has_stack_frames ())
12569 {
12570 prev_len = VEC_length (ada_exc_info, result);
12571 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
12572 &result);
12573 if (VEC_length (ada_exc_info, result) > prev_len)
12574 sort_remove_dups_ada_exceptions_list (&result, prev_len);
12575 }
12576
12577 /* Add all exceptions whose scope is global. */
12578
12579 prev_len = VEC_length (ada_exc_info, result);
12580 ada_add_global_exceptions (preg, &result);
12581 if (VEC_length (ada_exc_info, result) > prev_len)
12582 sort_remove_dups_ada_exceptions_list (&result, prev_len);
12583
12584 discard_cleanups (old_chain);
12585 return result;
12586}
12587
12588/* Return a vector of ada_exc_info.
12589
12590 If REGEXP is NULL, all exceptions are included in the result.
12591 Otherwise, it should contain a valid regular expression,
12592 and only the exceptions whose names match that regular expression
12593 are included in the result.
12594
12595 The exceptions are sorted in the following order:
12596 - Standard exceptions (defined by the Ada language), in
12597 alphabetical order;
12598 - Exceptions only visible from the current frame, in
12599 alphabetical order;
12600 - Exceptions whose scope is global, in alphabetical order. */
12601
12602VEC(ada_exc_info) *
12603ada_exceptions_list (const char *regexp)
12604{
12605 VEC(ada_exc_info) *result = NULL;
12606 struct cleanup *old_chain = NULL;
12607 regex_t reg;
12608
12609 if (regexp != NULL)
12610 old_chain = compile_rx_or_error (&reg, regexp,
12611 _("invalid regular expression"));
12612
12613 result = ada_exceptions_list_1 (regexp != NULL ? &reg : NULL);
12614
12615 if (old_chain != NULL)
12616 do_cleanups (old_chain);
12617 return result;
12618}
12619
12620/* Implement the "info exceptions" command. */
12621
12622static void
12623info_exceptions_command (char *regexp, int from_tty)
12624{
12625 VEC(ada_exc_info) *exceptions;
12626 struct cleanup *cleanup;
12627 struct gdbarch *gdbarch = get_current_arch ();
12628 int ix;
12629 struct ada_exc_info *info;
12630
12631 exceptions = ada_exceptions_list (regexp);
12632 cleanup = make_cleanup (VEC_cleanup (ada_exc_info), &exceptions);
12633
12634 if (regexp != NULL)
12635 printf_filtered
12636 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
12637 else
12638 printf_filtered (_("All defined Ada exceptions:\n"));
12639
12640 for (ix = 0; VEC_iterate(ada_exc_info, exceptions, ix, info); ix++)
12641 printf_filtered ("%s: %s\n", info->name, paddress (gdbarch, info->addr));
12642
12643 do_cleanups (cleanup);
12644}
12645
4c4b4cd2
PH
12646 /* Operators */
12647/* Information about operators given special treatment in functions
12648 below. */
12649/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
12650
12651#define ADA_OPERATORS \
12652 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
12653 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
12654 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
12655 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
12656 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
12657 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
12658 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
12659 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
12660 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
12661 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
12662 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
12663 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
12664 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
12665 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
12666 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
12667 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
12668 OP_DEFN (OP_OTHERS, 1, 1, 0) \
12669 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
12670 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
12671
12672static void
554794dc
SDJ
12673ada_operator_length (const struct expression *exp, int pc, int *oplenp,
12674 int *argsp)
4c4b4cd2
PH
12675{
12676 switch (exp->elts[pc - 1].opcode)
12677 {
76a01679 12678 default:
4c4b4cd2
PH
12679 operator_length_standard (exp, pc, oplenp, argsp);
12680 break;
12681
12682#define OP_DEFN(op, len, args, binop) \
12683 case op: *oplenp = len; *argsp = args; break;
12684 ADA_OPERATORS;
12685#undef OP_DEFN
52ce6436
PH
12686
12687 case OP_AGGREGATE:
12688 *oplenp = 3;
12689 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
12690 break;
12691
12692 case OP_CHOICES:
12693 *oplenp = 3;
12694 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
12695 break;
4c4b4cd2
PH
12696 }
12697}
12698
c0201579
JK
12699/* Implementation of the exp_descriptor method operator_check. */
12700
12701static int
12702ada_operator_check (struct expression *exp, int pos,
12703 int (*objfile_func) (struct objfile *objfile, void *data),
12704 void *data)
12705{
12706 const union exp_element *const elts = exp->elts;
12707 struct type *type = NULL;
12708
12709 switch (elts[pos].opcode)
12710 {
12711 case UNOP_IN_RANGE:
12712 case UNOP_QUAL:
12713 type = elts[pos + 1].type;
12714 break;
12715
12716 default:
12717 return operator_check_standard (exp, pos, objfile_func, data);
12718 }
12719
12720 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
12721
12722 if (type && TYPE_OBJFILE (type)
12723 && (*objfile_func) (TYPE_OBJFILE (type), data))
12724 return 1;
12725
12726 return 0;
12727}
12728
4c4b4cd2
PH
12729static char *
12730ada_op_name (enum exp_opcode opcode)
12731{
12732 switch (opcode)
12733 {
76a01679 12734 default:
4c4b4cd2 12735 return op_name_standard (opcode);
52ce6436 12736
4c4b4cd2
PH
12737#define OP_DEFN(op, len, args, binop) case op: return #op;
12738 ADA_OPERATORS;
12739#undef OP_DEFN
52ce6436
PH
12740
12741 case OP_AGGREGATE:
12742 return "OP_AGGREGATE";
12743 case OP_CHOICES:
12744 return "OP_CHOICES";
12745 case OP_NAME:
12746 return "OP_NAME";
4c4b4cd2
PH
12747 }
12748}
12749
12750/* As for operator_length, but assumes PC is pointing at the first
12751 element of the operator, and gives meaningful results only for the
52ce6436 12752 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
12753
12754static void
76a01679
JB
12755ada_forward_operator_length (struct expression *exp, int pc,
12756 int *oplenp, int *argsp)
4c4b4cd2 12757{
76a01679 12758 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
12759 {
12760 default:
12761 *oplenp = *argsp = 0;
12762 break;
52ce6436 12763
4c4b4cd2
PH
12764#define OP_DEFN(op, len, args, binop) \
12765 case op: *oplenp = len; *argsp = args; break;
12766 ADA_OPERATORS;
12767#undef OP_DEFN
52ce6436
PH
12768
12769 case OP_AGGREGATE:
12770 *oplenp = 3;
12771 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
12772 break;
12773
12774 case OP_CHOICES:
12775 *oplenp = 3;
12776 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
12777 break;
12778
12779 case OP_STRING:
12780 case OP_NAME:
12781 {
12782 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 12783
52ce6436
PH
12784 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
12785 *argsp = 0;
12786 break;
12787 }
4c4b4cd2
PH
12788 }
12789}
12790
12791static int
12792ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
12793{
12794 enum exp_opcode op = exp->elts[elt].opcode;
12795 int oplen, nargs;
12796 int pc = elt;
12797 int i;
76a01679 12798
4c4b4cd2
PH
12799 ada_forward_operator_length (exp, elt, &oplen, &nargs);
12800
76a01679 12801 switch (op)
4c4b4cd2 12802 {
76a01679 12803 /* Ada attributes ('Foo). */
4c4b4cd2
PH
12804 case OP_ATR_FIRST:
12805 case OP_ATR_LAST:
12806 case OP_ATR_LENGTH:
12807 case OP_ATR_IMAGE:
12808 case OP_ATR_MAX:
12809 case OP_ATR_MIN:
12810 case OP_ATR_MODULUS:
12811 case OP_ATR_POS:
12812 case OP_ATR_SIZE:
12813 case OP_ATR_TAG:
12814 case OP_ATR_VAL:
12815 break;
12816
12817 case UNOP_IN_RANGE:
12818 case UNOP_QUAL:
323e0a4a
AC
12819 /* XXX: gdb_sprint_host_address, type_sprint */
12820 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
12821 gdb_print_host_address (exp->elts[pc + 1].type, stream);
12822 fprintf_filtered (stream, " (");
12823 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
12824 fprintf_filtered (stream, ")");
12825 break;
12826 case BINOP_IN_BOUNDS:
52ce6436
PH
12827 fprintf_filtered (stream, " (%d)",
12828 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
12829 break;
12830 case TERNOP_IN_RANGE:
12831 break;
12832
52ce6436
PH
12833 case OP_AGGREGATE:
12834 case OP_OTHERS:
12835 case OP_DISCRETE_RANGE:
12836 case OP_POSITIONAL:
12837 case OP_CHOICES:
12838 break;
12839
12840 case OP_NAME:
12841 case OP_STRING:
12842 {
12843 char *name = &exp->elts[elt + 2].string;
12844 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 12845
52ce6436
PH
12846 fprintf_filtered (stream, "Text: `%.*s'", len, name);
12847 break;
12848 }
12849
4c4b4cd2
PH
12850 default:
12851 return dump_subexp_body_standard (exp, stream, elt);
12852 }
12853
12854 elt += oplen;
12855 for (i = 0; i < nargs; i += 1)
12856 elt = dump_subexp (exp, stream, elt);
12857
12858 return elt;
12859}
12860
12861/* The Ada extension of print_subexp (q.v.). */
12862
76a01679
JB
12863static void
12864ada_print_subexp (struct expression *exp, int *pos,
12865 struct ui_file *stream, enum precedence prec)
4c4b4cd2 12866{
52ce6436 12867 int oplen, nargs, i;
4c4b4cd2
PH
12868 int pc = *pos;
12869 enum exp_opcode op = exp->elts[pc].opcode;
12870
12871 ada_forward_operator_length (exp, pc, &oplen, &nargs);
12872
52ce6436 12873 *pos += oplen;
4c4b4cd2
PH
12874 switch (op)
12875 {
12876 default:
52ce6436 12877 *pos -= oplen;
4c4b4cd2
PH
12878 print_subexp_standard (exp, pos, stream, prec);
12879 return;
12880
12881 case OP_VAR_VALUE:
4c4b4cd2
PH
12882 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
12883 return;
12884
12885 case BINOP_IN_BOUNDS:
323e0a4a 12886 /* XXX: sprint_subexp */
4c4b4cd2 12887 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12888 fputs_filtered (" in ", stream);
4c4b4cd2 12889 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12890 fputs_filtered ("'range", stream);
4c4b4cd2 12891 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
12892 fprintf_filtered (stream, "(%ld)",
12893 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
12894 return;
12895
12896 case TERNOP_IN_RANGE:
4c4b4cd2 12897 if (prec >= PREC_EQUAL)
76a01679 12898 fputs_filtered ("(", stream);
323e0a4a 12899 /* XXX: sprint_subexp */
4c4b4cd2 12900 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12901 fputs_filtered (" in ", stream);
4c4b4cd2
PH
12902 print_subexp (exp, pos, stream, PREC_EQUAL);
12903 fputs_filtered (" .. ", stream);
12904 print_subexp (exp, pos, stream, PREC_EQUAL);
12905 if (prec >= PREC_EQUAL)
76a01679
JB
12906 fputs_filtered (")", stream);
12907 return;
4c4b4cd2
PH
12908
12909 case OP_ATR_FIRST:
12910 case OP_ATR_LAST:
12911 case OP_ATR_LENGTH:
12912 case OP_ATR_IMAGE:
12913 case OP_ATR_MAX:
12914 case OP_ATR_MIN:
12915 case OP_ATR_MODULUS:
12916 case OP_ATR_POS:
12917 case OP_ATR_SIZE:
12918 case OP_ATR_TAG:
12919 case OP_ATR_VAL:
4c4b4cd2 12920 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
12921 {
12922 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
12923 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
12924 &type_print_raw_options);
76a01679
JB
12925 *pos += 3;
12926 }
4c4b4cd2 12927 else
76a01679 12928 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
12929 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
12930 if (nargs > 1)
76a01679
JB
12931 {
12932 int tem;
5b4ee69b 12933
76a01679
JB
12934 for (tem = 1; tem < nargs; tem += 1)
12935 {
12936 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
12937 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
12938 }
12939 fputs_filtered (")", stream);
12940 }
4c4b4cd2 12941 return;
14f9c5c9 12942
4c4b4cd2 12943 case UNOP_QUAL:
4c4b4cd2
PH
12944 type_print (exp->elts[pc + 1].type, "", stream, 0);
12945 fputs_filtered ("'(", stream);
12946 print_subexp (exp, pos, stream, PREC_PREFIX);
12947 fputs_filtered (")", stream);
12948 return;
14f9c5c9 12949
4c4b4cd2 12950 case UNOP_IN_RANGE:
323e0a4a 12951 /* XXX: sprint_subexp */
4c4b4cd2 12952 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12953 fputs_filtered (" in ", stream);
79d43c61
TT
12954 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
12955 &type_print_raw_options);
4c4b4cd2 12956 return;
52ce6436
PH
12957
12958 case OP_DISCRETE_RANGE:
12959 print_subexp (exp, pos, stream, PREC_SUFFIX);
12960 fputs_filtered ("..", stream);
12961 print_subexp (exp, pos, stream, PREC_SUFFIX);
12962 return;
12963
12964 case OP_OTHERS:
12965 fputs_filtered ("others => ", stream);
12966 print_subexp (exp, pos, stream, PREC_SUFFIX);
12967 return;
12968
12969 case OP_CHOICES:
12970 for (i = 0; i < nargs-1; i += 1)
12971 {
12972 if (i > 0)
12973 fputs_filtered ("|", stream);
12974 print_subexp (exp, pos, stream, PREC_SUFFIX);
12975 }
12976 fputs_filtered (" => ", stream);
12977 print_subexp (exp, pos, stream, PREC_SUFFIX);
12978 return;
12979
12980 case OP_POSITIONAL:
12981 print_subexp (exp, pos, stream, PREC_SUFFIX);
12982 return;
12983
12984 case OP_AGGREGATE:
12985 fputs_filtered ("(", stream);
12986 for (i = 0; i < nargs; i += 1)
12987 {
12988 if (i > 0)
12989 fputs_filtered (", ", stream);
12990 print_subexp (exp, pos, stream, PREC_SUFFIX);
12991 }
12992 fputs_filtered (")", stream);
12993 return;
4c4b4cd2
PH
12994 }
12995}
14f9c5c9
AS
12996
12997/* Table mapping opcodes into strings for printing operators
12998 and precedences of the operators. */
12999
d2e4a39e
AS
13000static const struct op_print ada_op_print_tab[] = {
13001 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13002 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13003 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13004 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13005 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13006 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13007 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13008 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13009 {"<=", BINOP_LEQ, PREC_ORDER, 0},
13010 {">=", BINOP_GEQ, PREC_ORDER, 0},
13011 {">", BINOP_GTR, PREC_ORDER, 0},
13012 {"<", BINOP_LESS, PREC_ORDER, 0},
13013 {">>", BINOP_RSH, PREC_SHIFT, 0},
13014 {"<<", BINOP_LSH, PREC_SHIFT, 0},
13015 {"+", BINOP_ADD, PREC_ADD, 0},
13016 {"-", BINOP_SUB, PREC_ADD, 0},
13017 {"&", BINOP_CONCAT, PREC_ADD, 0},
13018 {"*", BINOP_MUL, PREC_MUL, 0},
13019 {"/", BINOP_DIV, PREC_MUL, 0},
13020 {"rem", BINOP_REM, PREC_MUL, 0},
13021 {"mod", BINOP_MOD, PREC_MUL, 0},
13022 {"**", BINOP_EXP, PREC_REPEAT, 0},
13023 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13024 {"-", UNOP_NEG, PREC_PREFIX, 0},
13025 {"+", UNOP_PLUS, PREC_PREFIX, 0},
13026 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13027 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13028 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
13029 {".all", UNOP_IND, PREC_SUFFIX, 1},
13030 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13031 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
d2e4a39e 13032 {NULL, 0, 0, 0}
14f9c5c9
AS
13033};
13034\f
72d5681a
PH
13035enum ada_primitive_types {
13036 ada_primitive_type_int,
13037 ada_primitive_type_long,
13038 ada_primitive_type_short,
13039 ada_primitive_type_char,
13040 ada_primitive_type_float,
13041 ada_primitive_type_double,
13042 ada_primitive_type_void,
13043 ada_primitive_type_long_long,
13044 ada_primitive_type_long_double,
13045 ada_primitive_type_natural,
13046 ada_primitive_type_positive,
13047 ada_primitive_type_system_address,
13048 nr_ada_primitive_types
13049};
6c038f32
PH
13050
13051static void
d4a9a881 13052ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
13053 struct language_arch_info *lai)
13054{
d4a9a881 13055 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 13056
72d5681a 13057 lai->primitive_type_vector
d4a9a881 13058 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 13059 struct type *);
e9bb382b
UW
13060
13061 lai->primitive_type_vector [ada_primitive_type_int]
13062 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13063 0, "integer");
13064 lai->primitive_type_vector [ada_primitive_type_long]
13065 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13066 0, "long_integer");
13067 lai->primitive_type_vector [ada_primitive_type_short]
13068 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13069 0, "short_integer");
13070 lai->string_char_type
13071 = lai->primitive_type_vector [ada_primitive_type_char]
13072 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
13073 lai->primitive_type_vector [ada_primitive_type_float]
13074 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13075 "float", NULL);
13076 lai->primitive_type_vector [ada_primitive_type_double]
13077 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13078 "long_float", NULL);
13079 lai->primitive_type_vector [ada_primitive_type_long_long]
13080 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13081 0, "long_long_integer");
13082 lai->primitive_type_vector [ada_primitive_type_long_double]
13083 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13084 "long_long_float", NULL);
13085 lai->primitive_type_vector [ada_primitive_type_natural]
13086 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13087 0, "natural");
13088 lai->primitive_type_vector [ada_primitive_type_positive]
13089 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13090 0, "positive");
13091 lai->primitive_type_vector [ada_primitive_type_void]
13092 = builtin->builtin_void;
13093
13094 lai->primitive_type_vector [ada_primitive_type_system_address]
13095 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
72d5681a
PH
13096 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
13097 = "system__address";
fbb06eb1 13098
47e729a8 13099 lai->bool_type_symbol = NULL;
fbb06eb1 13100 lai->bool_type_default = builtin->builtin_bool;
6c038f32 13101}
6c038f32
PH
13102\f
13103 /* Language vector */
13104
13105/* Not really used, but needed in the ada_language_defn. */
13106
13107static void
6c7a06a3 13108emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 13109{
6c7a06a3 13110 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
13111}
13112
13113static int
13114parse (void)
13115{
13116 warnings_issued = 0;
13117 return ada_parse ();
13118}
13119
13120static const struct exp_descriptor ada_exp_descriptor = {
13121 ada_print_subexp,
13122 ada_operator_length,
c0201579 13123 ada_operator_check,
6c038f32
PH
13124 ada_op_name,
13125 ada_dump_subexp_body,
13126 ada_evaluate_subexp
13127};
13128
1a119f36 13129/* Implement the "la_get_symbol_name_cmp" language_defn method
74ccd7f5
JB
13130 for Ada. */
13131
1a119f36
JB
13132static symbol_name_cmp_ftype
13133ada_get_symbol_name_cmp (const char *lookup_name)
74ccd7f5
JB
13134{
13135 if (should_use_wild_match (lookup_name))
13136 return wild_match;
13137 else
13138 return compare_names;
13139}
13140
a5ee536b
JB
13141/* Implement the "la_read_var_value" language_defn method for Ada. */
13142
13143static struct value *
13144ada_read_var_value (struct symbol *var, struct frame_info *frame)
13145{
13146 struct block *frame_block = NULL;
13147 struct symbol *renaming_sym = NULL;
13148
13149 /* The only case where default_read_var_value is not sufficient
13150 is when VAR is a renaming... */
13151 if (frame)
13152 frame_block = get_frame_block (frame, NULL);
13153 if (frame_block)
13154 renaming_sym = ada_find_renaming_symbol (var, frame_block);
13155 if (renaming_sym != NULL)
13156 return ada_read_renaming_var_value (renaming_sym, frame_block);
13157
13158 /* This is a typical case where we expect the default_read_var_value
13159 function to work. */
13160 return default_read_var_value (var, frame);
13161}
13162
6c038f32
PH
13163const struct language_defn ada_language_defn = {
13164 "ada", /* Language name */
6abde28f 13165 "Ada",
6c038f32 13166 language_ada,
6c038f32 13167 range_check_off,
6c038f32
PH
13168 case_sensitive_on, /* Yes, Ada is case-insensitive, but
13169 that's not quite what this means. */
6c038f32 13170 array_row_major,
9a044a89 13171 macro_expansion_no,
6c038f32
PH
13172 &ada_exp_descriptor,
13173 parse,
13174 ada_error,
13175 resolve,
13176 ada_printchar, /* Print a character constant */
13177 ada_printstr, /* Function to print string constant */
13178 emit_char, /* Function to print single char (not used) */
6c038f32 13179 ada_print_type, /* Print a type using appropriate syntax */
be942545 13180 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
13181 ada_val_print, /* Print a value using appropriate syntax */
13182 ada_value_print, /* Print a top-level value */
a5ee536b 13183 ada_read_var_value, /* la_read_var_value */
6c038f32 13184 NULL, /* Language specific skip_trampoline */
2b2d9e11 13185 NULL, /* name_of_this */
6c038f32
PH
13186 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
13187 basic_lookup_transparent_type, /* lookup_transparent_type */
13188 ada_la_decode, /* Language specific symbol demangler */
0963b4bd
MS
13189 NULL, /* Language specific
13190 class_name_from_physname */
6c038f32
PH
13191 ada_op_print_tab, /* expression operators for printing */
13192 0, /* c-style arrays */
13193 1, /* String lower bound */
6c038f32 13194 ada_get_gdb_completer_word_break_characters,
41d27058 13195 ada_make_symbol_completion_list,
72d5681a 13196 ada_language_arch_info,
e79af960 13197 ada_print_array_index,
41f1b697 13198 default_pass_by_reference,
ae6a3a4c 13199 c_get_string,
1a119f36 13200 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
f8eba3c6 13201 ada_iterate_over_symbols,
a53b64ea 13202 &ada_varobj_ops,
6c038f32
PH
13203 LANG_MAGIC
13204};
13205
2c0b251b
PA
13206/* Provide a prototype to silence -Wmissing-prototypes. */
13207extern initialize_file_ftype _initialize_ada_language;
13208
5bf03f13
JB
13209/* Command-list for the "set/show ada" prefix command. */
13210static struct cmd_list_element *set_ada_list;
13211static struct cmd_list_element *show_ada_list;
13212
13213/* Implement the "set ada" prefix command. */
13214
13215static void
13216set_ada_command (char *arg, int from_tty)
13217{
13218 printf_unfiltered (_(\
13219"\"set ada\" must be followed by the name of a setting.\n"));
13220 help_list (set_ada_list, "set ada ", -1, gdb_stdout);
13221}
13222
13223/* Implement the "show ada" prefix command. */
13224
13225static void
13226show_ada_command (char *args, int from_tty)
13227{
13228 cmd_show_list (show_ada_list, from_tty, "");
13229}
13230
2060206e
PA
13231static void
13232initialize_ada_catchpoint_ops (void)
13233{
13234 struct breakpoint_ops *ops;
13235
13236 initialize_breakpoint_ops ();
13237
13238 ops = &catch_exception_breakpoint_ops;
13239 *ops = bkpt_breakpoint_ops;
13240 ops->dtor = dtor_catch_exception;
13241 ops->allocate_location = allocate_location_catch_exception;
13242 ops->re_set = re_set_catch_exception;
13243 ops->check_status = check_status_catch_exception;
13244 ops->print_it = print_it_catch_exception;
13245 ops->print_one = print_one_catch_exception;
13246 ops->print_mention = print_mention_catch_exception;
13247 ops->print_recreate = print_recreate_catch_exception;
13248
13249 ops = &catch_exception_unhandled_breakpoint_ops;
13250 *ops = bkpt_breakpoint_ops;
13251 ops->dtor = dtor_catch_exception_unhandled;
13252 ops->allocate_location = allocate_location_catch_exception_unhandled;
13253 ops->re_set = re_set_catch_exception_unhandled;
13254 ops->check_status = check_status_catch_exception_unhandled;
13255 ops->print_it = print_it_catch_exception_unhandled;
13256 ops->print_one = print_one_catch_exception_unhandled;
13257 ops->print_mention = print_mention_catch_exception_unhandled;
13258 ops->print_recreate = print_recreate_catch_exception_unhandled;
13259
13260 ops = &catch_assert_breakpoint_ops;
13261 *ops = bkpt_breakpoint_ops;
13262 ops->dtor = dtor_catch_assert;
13263 ops->allocate_location = allocate_location_catch_assert;
13264 ops->re_set = re_set_catch_assert;
13265 ops->check_status = check_status_catch_assert;
13266 ops->print_it = print_it_catch_assert;
13267 ops->print_one = print_one_catch_assert;
13268 ops->print_mention = print_mention_catch_assert;
13269 ops->print_recreate = print_recreate_catch_assert;
13270}
13271
d2e4a39e 13272void
6c038f32 13273_initialize_ada_language (void)
14f9c5c9 13274{
6c038f32
PH
13275 add_language (&ada_language_defn);
13276
2060206e
PA
13277 initialize_ada_catchpoint_ops ();
13278
5bf03f13
JB
13279 add_prefix_cmd ("ada", no_class, set_ada_command,
13280 _("Prefix command for changing Ada-specfic settings"),
13281 &set_ada_list, "set ada ", 0, &setlist);
13282
13283 add_prefix_cmd ("ada", no_class, show_ada_command,
13284 _("Generic command for showing Ada-specific settings."),
13285 &show_ada_list, "show ada ", 0, &showlist);
13286
13287 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13288 &trust_pad_over_xvs, _("\
13289Enable or disable an optimization trusting PAD types over XVS types"), _("\
13290Show whether an optimization trusting PAD types over XVS types is activated"),
13291 _("\
13292This is related to the encoding used by the GNAT compiler. The debugger\n\
13293should normally trust the contents of PAD types, but certain older versions\n\
13294of GNAT have a bug that sometimes causes the information in the PAD type\n\
13295to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13296work around this bug. It is always safe to turn this option \"off\", but\n\
13297this incurs a slight performance penalty, so it is recommended to NOT change\n\
13298this option to \"off\" unless necessary."),
13299 NULL, NULL, &set_ada_list, &show_ada_list);
13300
9ac4176b
PA
13301 add_catch_command ("exception", _("\
13302Catch Ada exceptions, when raised.\n\
13303With an argument, catch only exceptions with the given name."),
13304 catch_ada_exception_command,
13305 NULL,
13306 CATCH_PERMANENT,
13307 CATCH_TEMPORARY);
13308 add_catch_command ("assert", _("\
13309Catch failed Ada assertions, when raised.\n\
13310With an argument, catch only exceptions with the given name."),
13311 catch_assert_command,
13312 NULL,
13313 CATCH_PERMANENT,
13314 CATCH_TEMPORARY);
13315
6c038f32 13316 varsize_limit = 65536;
6c038f32 13317
778865d3
JB
13318 add_info ("exceptions", info_exceptions_command,
13319 _("\
13320List all Ada exception names.\n\
13321If a regular expression is passed as an argument, only those matching\n\
13322the regular expression are listed."));
13323
6c038f32
PH
13324 obstack_init (&symbol_list_obstack);
13325
13326 decoded_names_store = htab_create_alloc
13327 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
13328 NULL, xcalloc, xfree);
6b69afc4 13329
e802dbe0
JB
13330 /* Setup per-inferior data. */
13331 observer_attach_inferior_exit (ada_inferior_exit);
13332 ada_inferior_data
8e260fc0 13333 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
14f9c5c9 13334}