]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
[Ada] Do not cache lookup result if not full_search
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
6e681866 1/* Ada language support routines for GDB, the GNU debugger.
10a2c479 2
0b302171
JB
3 Copyright (C) 1992-1994, 1997-2000, 2003-2005, 2007-2012 Free
4 Software Foundation, Inc.
14f9c5c9 5
a9762ec7 6 This file is part of GDB.
14f9c5c9 7
a9762ec7
JB
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3 of the License, or
11 (at your option) any later version.
14f9c5c9 12
a9762ec7
JB
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
14f9c5c9 17
a9762ec7
JB
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>. */
14f9c5c9 20
96d887e8 21
4c4b4cd2 22#include "defs.h"
14f9c5c9 23#include <stdio.h>
0c30c098 24#include "gdb_string.h"
14f9c5c9
AS
25#include <ctype.h>
26#include <stdarg.h>
27#include "demangle.h"
4c4b4cd2
PH
28#include "gdb_regex.h"
29#include "frame.h"
14f9c5c9
AS
30#include "symtab.h"
31#include "gdbtypes.h"
32#include "gdbcmd.h"
33#include "expression.h"
34#include "parser-defs.h"
35#include "language.h"
36#include "c-lang.h"
37#include "inferior.h"
38#include "symfile.h"
39#include "objfiles.h"
40#include "breakpoint.h"
41#include "gdbcore.h"
4c4b4cd2
PH
42#include "hashtab.h"
43#include "gdb_obstack.h"
14f9c5c9 44#include "ada-lang.h"
4c4b4cd2
PH
45#include "completer.h"
46#include "gdb_stat.h"
47#ifdef UI_OUT
14f9c5c9 48#include "ui-out.h"
4c4b4cd2 49#endif
fe898f56 50#include "block.h"
04714b91 51#include "infcall.h"
de4f826b 52#include "dictionary.h"
60250e8b 53#include "exceptions.h"
f7f9143b
JB
54#include "annotate.h"
55#include "valprint.h"
9bbc9174 56#include "source.h"
0259addd 57#include "observer.h"
2ba95b9b 58#include "vec.h"
692465f1 59#include "stack.h"
fa864999 60#include "gdb_vecs.h"
14f9c5c9 61
ccefe4c4 62#include "psymtab.h"
40bc484c 63#include "value.h"
956a9fb9 64#include "mi/mi-common.h"
9ac4176b 65#include "arch-utils.h"
28010a5d 66#include "exceptions.h"
0fcd72ba 67#include "cli/cli-utils.h"
ccefe4c4 68
4c4b4cd2 69/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 70 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
71 Copied from valarith.c. */
72
73#ifndef TRUNCATION_TOWARDS_ZERO
74#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
75#endif
76
d2e4a39e 77static struct type *desc_base_type (struct type *);
14f9c5c9 78
d2e4a39e 79static struct type *desc_bounds_type (struct type *);
14f9c5c9 80
d2e4a39e 81static struct value *desc_bounds (struct value *);
14f9c5c9 82
d2e4a39e 83static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 84
d2e4a39e 85static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 86
556bdfd4 87static struct type *desc_data_target_type (struct type *);
14f9c5c9 88
d2e4a39e 89static struct value *desc_data (struct value *);
14f9c5c9 90
d2e4a39e 91static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 92
d2e4a39e 93static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 94
d2e4a39e 95static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 96
d2e4a39e 97static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 98
d2e4a39e 99static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 100
d2e4a39e 101static struct type *desc_index_type (struct type *, int);
14f9c5c9 102
d2e4a39e 103static int desc_arity (struct type *);
14f9c5c9 104
d2e4a39e 105static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 106
d2e4a39e 107static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 108
40658b94
PH
109static int full_match (const char *, const char *);
110
40bc484c 111static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 112
4c4b4cd2 113static void ada_add_block_symbols (struct obstack *,
76a01679 114 struct block *, const char *,
2570f2b7 115 domain_enum, struct objfile *, int);
14f9c5c9 116
4c4b4cd2 117static int is_nonfunction (struct ada_symbol_info *, int);
14f9c5c9 118
76a01679 119static void add_defn_to_vec (struct obstack *, struct symbol *,
2570f2b7 120 struct block *);
14f9c5c9 121
4c4b4cd2
PH
122static int num_defns_collected (struct obstack *);
123
124static struct ada_symbol_info *defns_collected (struct obstack *, int);
14f9c5c9 125
4c4b4cd2 126static struct value *resolve_subexp (struct expression **, int *, int,
76a01679 127 struct type *);
14f9c5c9 128
d2e4a39e 129static void replace_operator_with_call (struct expression **, int, int, int,
4c4b4cd2 130 struct symbol *, struct block *);
14f9c5c9 131
d2e4a39e 132static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 133
4c4b4cd2
PH
134static char *ada_op_name (enum exp_opcode);
135
136static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 137
d2e4a39e 138static int numeric_type_p (struct type *);
14f9c5c9 139
d2e4a39e 140static int integer_type_p (struct type *);
14f9c5c9 141
d2e4a39e 142static int scalar_type_p (struct type *);
14f9c5c9 143
d2e4a39e 144static int discrete_type_p (struct type *);
14f9c5c9 145
aeb5907d
JB
146static enum ada_renaming_category parse_old_style_renaming (struct type *,
147 const char **,
148 int *,
149 const char **);
150
151static struct symbol *find_old_style_renaming_symbol (const char *,
152 struct block *);
153
4c4b4cd2 154static struct type *ada_lookup_struct_elt_type (struct type *, char *,
76a01679 155 int, int, int *);
4c4b4cd2 156
d2e4a39e 157static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 158
b4ba55a1
JB
159static struct type *ada_find_parallel_type_with_name (struct type *,
160 const char *);
161
d2e4a39e 162static int is_dynamic_field (struct type *, int);
14f9c5c9 163
10a2c479 164static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 165 const gdb_byte *,
4c4b4cd2
PH
166 CORE_ADDR, struct value *);
167
168static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 169
28c85d6c 170static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 171
d2e4a39e 172static struct type *to_static_fixed_type (struct type *);
f192137b 173static struct type *static_unwrap_type (struct type *type);
14f9c5c9 174
d2e4a39e 175static struct value *unwrap_value (struct value *);
14f9c5c9 176
ad82864c 177static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 178
ad82864c 179static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 180
ad82864c
JB
181static long decode_packed_array_bitsize (struct type *);
182
183static struct value *decode_constrained_packed_array (struct value *);
184
185static int ada_is_packed_array_type (struct type *);
186
187static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 188
d2e4a39e 189static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 190 struct value **);
14f9c5c9 191
50810684 192static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
52ce6436 193
4c4b4cd2
PH
194static struct value *coerce_unspec_val_to_type (struct value *,
195 struct type *);
14f9c5c9 196
d2e4a39e 197static struct value *get_var_value (char *, char *);
14f9c5c9 198
d2e4a39e 199static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 200
d2e4a39e 201static int equiv_types (struct type *, struct type *);
14f9c5c9 202
d2e4a39e 203static int is_name_suffix (const char *);
14f9c5c9 204
73589123
PH
205static int advance_wild_match (const char **, const char *, int);
206
207static int wild_match (const char *, const char *);
14f9c5c9 208
d2e4a39e 209static struct value *ada_coerce_ref (struct value *);
14f9c5c9 210
4c4b4cd2
PH
211static LONGEST pos_atr (struct value *);
212
3cb382c9 213static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 214
d2e4a39e 215static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 216
4c4b4cd2
PH
217static struct symbol *standard_lookup (const char *, const struct block *,
218 domain_enum);
14f9c5c9 219
4c4b4cd2
PH
220static struct value *ada_search_struct_field (char *, struct value *, int,
221 struct type *);
222
223static struct value *ada_value_primitive_field (struct value *, int, int,
224 struct type *);
225
0d5cff50 226static int find_struct_field (const char *, struct type *, int,
52ce6436 227 struct type **, int *, int *, int *, int *);
4c4b4cd2
PH
228
229static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
230 struct value *);
231
4c4b4cd2
PH
232static int ada_resolve_function (struct ada_symbol_info *, int,
233 struct value **, int, const char *,
234 struct type *);
235
4c4b4cd2
PH
236static int ada_is_direct_array_type (struct type *);
237
72d5681a
PH
238static void ada_language_arch_info (struct gdbarch *,
239 struct language_arch_info *);
714e53ab
PH
240
241static void check_size (const struct type *);
52ce6436
PH
242
243static struct value *ada_index_struct_field (int, struct value *, int,
244 struct type *);
245
246static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
247 struct expression *,
248 int *, enum noside);
52ce6436
PH
249
250static void aggregate_assign_from_choices (struct value *, struct value *,
251 struct expression *,
252 int *, LONGEST *, int *,
253 int, LONGEST, LONGEST);
254
255static void aggregate_assign_positional (struct value *, struct value *,
256 struct expression *,
257 int *, LONGEST *, int *, int,
258 LONGEST, LONGEST);
259
260
261static void aggregate_assign_others (struct value *, struct value *,
262 struct expression *,
263 int *, LONGEST *, int, LONGEST, LONGEST);
264
265
266static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
267
268
269static struct value *ada_evaluate_subexp (struct type *, struct expression *,
270 int *, enum noside);
271
272static void ada_forward_operator_length (struct expression *, int, int *,
273 int *);
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 {
359 data = XZALLOC (struct ada_inferior_data);
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));
14f9c5c9
AS
582 return result;
583 }
584}
585
fc1a4b47
AC
586static const gdb_byte *
587cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
588{
589 if (valaddr == NULL)
590 return NULL;
591 else
592 return valaddr + offset;
593}
594
595static CORE_ADDR
ebf56fd3 596cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
597{
598 if (address == 0)
599 return 0;
d2e4a39e 600 else
14f9c5c9
AS
601 return address + offset;
602}
603
4c4b4cd2
PH
604/* Issue a warning (as for the definition of warning in utils.c, but
605 with exactly one argument rather than ...), unless the limit on the
606 number of warnings has passed during the evaluation of the current
607 expression. */
a2249542 608
77109804
AC
609/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
610 provided by "complaint". */
a0b31db1 611static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 612
14f9c5c9 613static void
a2249542 614lim_warning (const char *format, ...)
14f9c5c9 615{
a2249542 616 va_list args;
a2249542 617
5b4ee69b 618 va_start (args, format);
4c4b4cd2
PH
619 warnings_issued += 1;
620 if (warnings_issued <= warning_limit)
a2249542
MK
621 vwarning (format, args);
622
623 va_end (args);
4c4b4cd2
PH
624}
625
714e53ab
PH
626/* Issue an error if the size of an object of type T is unreasonable,
627 i.e. if it would be a bad idea to allocate a value of this type in
628 GDB. */
629
630static void
631check_size (const struct type *type)
632{
633 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 634 error (_("object size is larger than varsize-limit"));
714e53ab
PH
635}
636
0963b4bd 637/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 638static LONGEST
c3e5cd34 639max_of_size (int size)
4c4b4cd2 640{
76a01679 641 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 642
76a01679 643 return top_bit | (top_bit - 1);
4c4b4cd2
PH
644}
645
0963b4bd 646/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 647static LONGEST
c3e5cd34 648min_of_size (int size)
4c4b4cd2 649{
c3e5cd34 650 return -max_of_size (size) - 1;
4c4b4cd2
PH
651}
652
0963b4bd 653/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 654static ULONGEST
c3e5cd34 655umax_of_size (int size)
4c4b4cd2 656{
76a01679 657 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 658
76a01679 659 return top_bit | (top_bit - 1);
4c4b4cd2
PH
660}
661
0963b4bd 662/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
663static LONGEST
664max_of_type (struct type *t)
4c4b4cd2 665{
c3e5cd34
PH
666 if (TYPE_UNSIGNED (t))
667 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
668 else
669 return max_of_size (TYPE_LENGTH (t));
670}
671
0963b4bd 672/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
673static LONGEST
674min_of_type (struct type *t)
675{
676 if (TYPE_UNSIGNED (t))
677 return 0;
678 else
679 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
680}
681
682/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
683LONGEST
684ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 685{
76a01679 686 switch (TYPE_CODE (type))
4c4b4cd2
PH
687 {
688 case TYPE_CODE_RANGE:
690cc4eb 689 return TYPE_HIGH_BOUND (type);
4c4b4cd2 690 case TYPE_CODE_ENUM:
690cc4eb
PH
691 return TYPE_FIELD_BITPOS (type, TYPE_NFIELDS (type) - 1);
692 case TYPE_CODE_BOOL:
693 return 1;
694 case TYPE_CODE_CHAR:
76a01679 695 case TYPE_CODE_INT:
690cc4eb 696 return max_of_type (type);
4c4b4cd2 697 default:
43bbcdc2 698 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
699 }
700}
701
702/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
703LONGEST
704ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 705{
76a01679 706 switch (TYPE_CODE (type))
4c4b4cd2
PH
707 {
708 case TYPE_CODE_RANGE:
690cc4eb 709 return TYPE_LOW_BOUND (type);
4c4b4cd2 710 case TYPE_CODE_ENUM:
690cc4eb
PH
711 return TYPE_FIELD_BITPOS (type, 0);
712 case TYPE_CODE_BOOL:
713 return 0;
714 case TYPE_CODE_CHAR:
76a01679 715 case TYPE_CODE_INT:
690cc4eb 716 return min_of_type (type);
4c4b4cd2 717 default:
43bbcdc2 718 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
719 }
720}
721
722/* The identity on non-range types. For range types, the underlying
76a01679 723 non-range scalar type. */
4c4b4cd2
PH
724
725static struct type *
18af8284 726get_base_type (struct type *type)
4c4b4cd2
PH
727{
728 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
729 {
76a01679
JB
730 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
731 return type;
4c4b4cd2
PH
732 type = TYPE_TARGET_TYPE (type);
733 }
734 return type;
14f9c5c9 735}
4c4b4cd2 736\f
76a01679 737
4c4b4cd2 738 /* Language Selection */
14f9c5c9
AS
739
740/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 741 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 742
14f9c5c9 743enum language
ccefe4c4 744ada_update_initial_language (enum language lang)
14f9c5c9 745{
d2e4a39e 746 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
4c4b4cd2
PH
747 (struct objfile *) NULL) != NULL)
748 return language_ada;
14f9c5c9
AS
749
750 return lang;
751}
96d887e8
PH
752
753/* If the main procedure is written in Ada, then return its name.
754 The result is good until the next call. Return NULL if the main
755 procedure doesn't appear to be in Ada. */
756
757char *
758ada_main_name (void)
759{
760 struct minimal_symbol *msym;
f9bc20b9 761 static char *main_program_name = NULL;
6c038f32 762
96d887e8
PH
763 /* For Ada, the name of the main procedure is stored in a specific
764 string constant, generated by the binder. Look for that symbol,
765 extract its address, and then read that string. If we didn't find
766 that string, then most probably the main procedure is not written
767 in Ada. */
768 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
769
770 if (msym != NULL)
771 {
f9bc20b9
JB
772 CORE_ADDR main_program_name_addr;
773 int err_code;
774
96d887e8
PH
775 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
776 if (main_program_name_addr == 0)
323e0a4a 777 error (_("Invalid address for Ada main program name."));
96d887e8 778
f9bc20b9
JB
779 xfree (main_program_name);
780 target_read_string (main_program_name_addr, &main_program_name,
781 1024, &err_code);
782
783 if (err_code != 0)
784 return NULL;
96d887e8
PH
785 return main_program_name;
786 }
787
788 /* The main procedure doesn't seem to be in Ada. */
789 return NULL;
790}
14f9c5c9 791\f
4c4b4cd2 792 /* Symbols */
d2e4a39e 793
4c4b4cd2
PH
794/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
795 of NULLs. */
14f9c5c9 796
d2e4a39e
AS
797const struct ada_opname_map ada_opname_table[] = {
798 {"Oadd", "\"+\"", BINOP_ADD},
799 {"Osubtract", "\"-\"", BINOP_SUB},
800 {"Omultiply", "\"*\"", BINOP_MUL},
801 {"Odivide", "\"/\"", BINOP_DIV},
802 {"Omod", "\"mod\"", BINOP_MOD},
803 {"Orem", "\"rem\"", BINOP_REM},
804 {"Oexpon", "\"**\"", BINOP_EXP},
805 {"Olt", "\"<\"", BINOP_LESS},
806 {"Ole", "\"<=\"", BINOP_LEQ},
807 {"Ogt", "\">\"", BINOP_GTR},
808 {"Oge", "\">=\"", BINOP_GEQ},
809 {"Oeq", "\"=\"", BINOP_EQUAL},
810 {"One", "\"/=\"", BINOP_NOTEQUAL},
811 {"Oand", "\"and\"", BINOP_BITWISE_AND},
812 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
813 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
814 {"Oconcat", "\"&\"", BINOP_CONCAT},
815 {"Oabs", "\"abs\"", UNOP_ABS},
816 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
817 {"Oadd", "\"+\"", UNOP_PLUS},
818 {"Osubtract", "\"-\"", UNOP_NEG},
819 {NULL, NULL}
14f9c5c9
AS
820};
821
4c4b4cd2
PH
822/* The "encoded" form of DECODED, according to GNAT conventions.
823 The result is valid until the next call to ada_encode. */
824
14f9c5c9 825char *
4c4b4cd2 826ada_encode (const char *decoded)
14f9c5c9 827{
4c4b4cd2
PH
828 static char *encoding_buffer = NULL;
829 static size_t encoding_buffer_size = 0;
d2e4a39e 830 const char *p;
14f9c5c9 831 int k;
d2e4a39e 832
4c4b4cd2 833 if (decoded == NULL)
14f9c5c9
AS
834 return NULL;
835
4c4b4cd2
PH
836 GROW_VECT (encoding_buffer, encoding_buffer_size,
837 2 * strlen (decoded) + 10);
14f9c5c9
AS
838
839 k = 0;
4c4b4cd2 840 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 841 {
cdc7bb92 842 if (*p == '.')
4c4b4cd2
PH
843 {
844 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
845 k += 2;
846 }
14f9c5c9 847 else if (*p == '"')
4c4b4cd2
PH
848 {
849 const struct ada_opname_map *mapping;
850
851 for (mapping = ada_opname_table;
1265e4aa
JB
852 mapping->encoded != NULL
853 && strncmp (mapping->decoded, p,
854 strlen (mapping->decoded)) != 0; mapping += 1)
4c4b4cd2
PH
855 ;
856 if (mapping->encoded == NULL)
323e0a4a 857 error (_("invalid Ada operator name: %s"), p);
4c4b4cd2
PH
858 strcpy (encoding_buffer + k, mapping->encoded);
859 k += strlen (mapping->encoded);
860 break;
861 }
d2e4a39e 862 else
4c4b4cd2
PH
863 {
864 encoding_buffer[k] = *p;
865 k += 1;
866 }
14f9c5c9
AS
867 }
868
4c4b4cd2
PH
869 encoding_buffer[k] = '\0';
870 return encoding_buffer;
14f9c5c9
AS
871}
872
873/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
874 quotes, unfolded, but with the quotes stripped away. Result good
875 to next call. */
876
d2e4a39e
AS
877char *
878ada_fold_name (const char *name)
14f9c5c9 879{
d2e4a39e 880 static char *fold_buffer = NULL;
14f9c5c9
AS
881 static size_t fold_buffer_size = 0;
882
883 int len = strlen (name);
d2e4a39e 884 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
885
886 if (name[0] == '\'')
887 {
d2e4a39e
AS
888 strncpy (fold_buffer, name + 1, len - 2);
889 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
890 }
891 else
892 {
893 int i;
5b4ee69b 894
14f9c5c9 895 for (i = 0; i <= len; i += 1)
4c4b4cd2 896 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
897 }
898
899 return fold_buffer;
900}
901
529cad9c
PH
902/* Return nonzero if C is either a digit or a lowercase alphabet character. */
903
904static int
905is_lower_alphanum (const char c)
906{
907 return (isdigit (c) || (isalpha (c) && islower (c)));
908}
909
c90092fe
JB
910/* ENCODED is the linkage name of a symbol and LEN contains its length.
911 This function saves in LEN the length of that same symbol name but
912 without either of these suffixes:
29480c32
JB
913 . .{DIGIT}+
914 . ${DIGIT}+
915 . ___{DIGIT}+
916 . __{DIGIT}+.
c90092fe 917
29480c32
JB
918 These are suffixes introduced by the compiler for entities such as
919 nested subprogram for instance, in order to avoid name clashes.
920 They do not serve any purpose for the debugger. */
921
922static void
923ada_remove_trailing_digits (const char *encoded, int *len)
924{
925 if (*len > 1 && isdigit (encoded[*len - 1]))
926 {
927 int i = *len - 2;
5b4ee69b 928
29480c32
JB
929 while (i > 0 && isdigit (encoded[i]))
930 i--;
931 if (i >= 0 && encoded[i] == '.')
932 *len = i;
933 else if (i >= 0 && encoded[i] == '$')
934 *len = i;
935 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
936 *len = i - 2;
937 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
938 *len = i - 1;
939 }
940}
941
942/* Remove the suffix introduced by the compiler for protected object
943 subprograms. */
944
945static void
946ada_remove_po_subprogram_suffix (const char *encoded, int *len)
947{
948 /* Remove trailing N. */
949
950 /* Protected entry subprograms are broken into two
951 separate subprograms: The first one is unprotected, and has
952 a 'N' suffix; the second is the protected version, and has
0963b4bd 953 the 'P' suffix. The second calls the first one after handling
29480c32
JB
954 the protection. Since the P subprograms are internally generated,
955 we leave these names undecoded, giving the user a clue that this
956 entity is internal. */
957
958 if (*len > 1
959 && encoded[*len - 1] == 'N'
960 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
961 *len = *len - 1;
962}
963
69fadcdf
JB
964/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
965
966static void
967ada_remove_Xbn_suffix (const char *encoded, int *len)
968{
969 int i = *len - 1;
970
971 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
972 i--;
973
974 if (encoded[i] != 'X')
975 return;
976
977 if (i == 0)
978 return;
979
980 if (isalnum (encoded[i-1]))
981 *len = i;
982}
983
29480c32
JB
984/* If ENCODED follows the GNAT entity encoding conventions, then return
985 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
986 replaced by ENCODED.
14f9c5c9 987
4c4b4cd2 988 The resulting string is valid until the next call of ada_decode.
29480c32 989 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
990 is returned. */
991
992const char *
993ada_decode (const char *encoded)
14f9c5c9
AS
994{
995 int i, j;
996 int len0;
d2e4a39e 997 const char *p;
4c4b4cd2 998 char *decoded;
14f9c5c9 999 int at_start_name;
4c4b4cd2
PH
1000 static char *decoding_buffer = NULL;
1001 static size_t decoding_buffer_size = 0;
d2e4a39e 1002
29480c32
JB
1003 /* The name of the Ada main procedure starts with "_ada_".
1004 This prefix is not part of the decoded name, so skip this part
1005 if we see this prefix. */
4c4b4cd2
PH
1006 if (strncmp (encoded, "_ada_", 5) == 0)
1007 encoded += 5;
14f9c5c9 1008
29480c32
JB
1009 /* If the name starts with '_', then it is not a properly encoded
1010 name, so do not attempt to decode it. Similarly, if the name
1011 starts with '<', the name should not be decoded. */
4c4b4cd2 1012 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1013 goto Suppress;
1014
4c4b4cd2 1015 len0 = strlen (encoded);
4c4b4cd2 1016
29480c32
JB
1017 ada_remove_trailing_digits (encoded, &len0);
1018 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1019
4c4b4cd2
PH
1020 /* Remove the ___X.* suffix if present. Do not forget to verify that
1021 the suffix is located before the current "end" of ENCODED. We want
1022 to avoid re-matching parts of ENCODED that have previously been
1023 marked as discarded (by decrementing LEN0). */
1024 p = strstr (encoded, "___");
1025 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1026 {
1027 if (p[3] == 'X')
4c4b4cd2 1028 len0 = p - encoded;
14f9c5c9 1029 else
4c4b4cd2 1030 goto Suppress;
14f9c5c9 1031 }
4c4b4cd2 1032
29480c32
JB
1033 /* Remove any trailing TKB suffix. It tells us that this symbol
1034 is for the body of a task, but that information does not actually
1035 appear in the decoded name. */
1036
4c4b4cd2 1037 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
14f9c5c9 1038 len0 -= 3;
76a01679 1039
a10967fa
JB
1040 /* Remove any trailing TB suffix. The TB suffix is slightly different
1041 from the TKB suffix because it is used for non-anonymous task
1042 bodies. */
1043
1044 if (len0 > 2 && strncmp (encoded + len0 - 2, "TB", 2) == 0)
1045 len0 -= 2;
1046
29480c32
JB
1047 /* Remove trailing "B" suffixes. */
1048 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1049
4c4b4cd2 1050 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
14f9c5c9
AS
1051 len0 -= 1;
1052
4c4b4cd2 1053 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1054
4c4b4cd2
PH
1055 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1056 decoded = decoding_buffer;
14f9c5c9 1057
29480c32
JB
1058 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1059
4c4b4cd2 1060 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1061 {
4c4b4cd2
PH
1062 i = len0 - 2;
1063 while ((i >= 0 && isdigit (encoded[i]))
1064 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1065 i -= 1;
1066 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1067 len0 = i - 1;
1068 else if (encoded[i] == '$')
1069 len0 = i;
d2e4a39e 1070 }
14f9c5c9 1071
29480c32
JB
1072 /* The first few characters that are not alphabetic are not part
1073 of any encoding we use, so we can copy them over verbatim. */
1074
4c4b4cd2
PH
1075 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1076 decoded[j] = encoded[i];
14f9c5c9
AS
1077
1078 at_start_name = 1;
1079 while (i < len0)
1080 {
29480c32 1081 /* Is this a symbol function? */
4c4b4cd2
PH
1082 if (at_start_name && encoded[i] == 'O')
1083 {
1084 int k;
5b4ee69b 1085
4c4b4cd2
PH
1086 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1087 {
1088 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1089 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1090 op_len - 1) == 0)
1091 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1092 {
1093 strcpy (decoded + j, ada_opname_table[k].decoded);
1094 at_start_name = 0;
1095 i += op_len;
1096 j += strlen (ada_opname_table[k].decoded);
1097 break;
1098 }
1099 }
1100 if (ada_opname_table[k].encoded != NULL)
1101 continue;
1102 }
14f9c5c9
AS
1103 at_start_name = 0;
1104
529cad9c
PH
1105 /* Replace "TK__" with "__", which will eventually be translated
1106 into "." (just below). */
1107
4c4b4cd2
PH
1108 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
1109 i += 2;
529cad9c 1110
29480c32
JB
1111 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1112 be translated into "." (just below). These are internal names
1113 generated for anonymous blocks inside which our symbol is nested. */
1114
1115 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1116 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1117 && isdigit (encoded [i+4]))
1118 {
1119 int k = i + 5;
1120
1121 while (k < len0 && isdigit (encoded[k]))
1122 k++; /* Skip any extra digit. */
1123
1124 /* Double-check that the "__B_{DIGITS}+" sequence we found
1125 is indeed followed by "__". */
1126 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1127 i = k;
1128 }
1129
529cad9c
PH
1130 /* Remove _E{DIGITS}+[sb] */
1131
1132 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1133 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1134 one implements the actual entry code, and has a suffix following
1135 the convention above; the second one implements the barrier and
1136 uses the same convention as above, except that the 'E' is replaced
1137 by a 'B'.
1138
1139 Just as above, we do not decode the name of barrier functions
1140 to give the user a clue that the code he is debugging has been
1141 internally generated. */
1142
1143 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1144 && isdigit (encoded[i+2]))
1145 {
1146 int k = i + 3;
1147
1148 while (k < len0 && isdigit (encoded[k]))
1149 k++;
1150
1151 if (k < len0
1152 && (encoded[k] == 'b' || encoded[k] == 's'))
1153 {
1154 k++;
1155 /* Just as an extra precaution, make sure that if this
1156 suffix is followed by anything else, it is a '_'.
1157 Otherwise, we matched this sequence by accident. */
1158 if (k == len0
1159 || (k < len0 && encoded[k] == '_'))
1160 i = k;
1161 }
1162 }
1163
1164 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1165 the GNAT front-end in protected object subprograms. */
1166
1167 if (i < len0 + 3
1168 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1169 {
1170 /* Backtrack a bit up until we reach either the begining of
1171 the encoded name, or "__". Make sure that we only find
1172 digits or lowercase characters. */
1173 const char *ptr = encoded + i - 1;
1174
1175 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1176 ptr--;
1177 if (ptr < encoded
1178 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1179 i++;
1180 }
1181
4c4b4cd2
PH
1182 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1183 {
29480c32
JB
1184 /* This is a X[bn]* sequence not separated from the previous
1185 part of the name with a non-alpha-numeric character (in other
1186 words, immediately following an alpha-numeric character), then
1187 verify that it is placed at the end of the encoded name. If
1188 not, then the encoding is not valid and we should abort the
1189 decoding. Otherwise, just skip it, it is used in body-nested
1190 package names. */
4c4b4cd2
PH
1191 do
1192 i += 1;
1193 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1194 if (i < len0)
1195 goto Suppress;
1196 }
cdc7bb92 1197 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1198 {
29480c32 1199 /* Replace '__' by '.'. */
4c4b4cd2
PH
1200 decoded[j] = '.';
1201 at_start_name = 1;
1202 i += 2;
1203 j += 1;
1204 }
14f9c5c9 1205 else
4c4b4cd2 1206 {
29480c32
JB
1207 /* It's a character part of the decoded name, so just copy it
1208 over. */
4c4b4cd2
PH
1209 decoded[j] = encoded[i];
1210 i += 1;
1211 j += 1;
1212 }
14f9c5c9 1213 }
4c4b4cd2 1214 decoded[j] = '\000';
14f9c5c9 1215
29480c32
JB
1216 /* Decoded names should never contain any uppercase character.
1217 Double-check this, and abort the decoding if we find one. */
1218
4c4b4cd2
PH
1219 for (i = 0; decoded[i] != '\0'; i += 1)
1220 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1221 goto Suppress;
1222
4c4b4cd2
PH
1223 if (strcmp (decoded, encoded) == 0)
1224 return encoded;
1225 else
1226 return decoded;
14f9c5c9
AS
1227
1228Suppress:
4c4b4cd2
PH
1229 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1230 decoded = decoding_buffer;
1231 if (encoded[0] == '<')
1232 strcpy (decoded, encoded);
14f9c5c9 1233 else
88c15c34 1234 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1235 return decoded;
1236
1237}
1238
1239/* Table for keeping permanent unique copies of decoded names. Once
1240 allocated, names in this table are never released. While this is a
1241 storage leak, it should not be significant unless there are massive
1242 changes in the set of decoded names in successive versions of a
1243 symbol table loaded during a single session. */
1244static struct htab *decoded_names_store;
1245
1246/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1247 in the language-specific part of GSYMBOL, if it has not been
1248 previously computed. Tries to save the decoded name in the same
1249 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1250 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1251 GSYMBOL).
4c4b4cd2
PH
1252 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1253 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1254 when a decoded name is cached in it. */
4c4b4cd2 1255
76a01679
JB
1256char *
1257ada_decode_symbol (const struct general_symbol_info *gsymbol)
4c4b4cd2 1258{
76a01679 1259 char **resultp =
afa16725 1260 (char **) &gsymbol->language_specific.mangled_lang.demangled_name;
5b4ee69b 1261
4c4b4cd2
PH
1262 if (*resultp == NULL)
1263 {
1264 const char *decoded = ada_decode (gsymbol->name);
5b4ee69b 1265
714835d5 1266 if (gsymbol->obj_section != NULL)
76a01679 1267 {
714835d5 1268 struct objfile *objf = gsymbol->obj_section->objfile;
5b4ee69b 1269
714835d5
UW
1270 *resultp = obsavestring (decoded, strlen (decoded),
1271 &objf->objfile_obstack);
76a01679 1272 }
4c4b4cd2 1273 /* Sometimes, we can't find a corresponding objfile, in which
76a01679
JB
1274 case, we put the result on the heap. Since we only decode
1275 when needed, we hope this usually does not cause a
1276 significant memory leak (FIXME). */
4c4b4cd2 1277 if (*resultp == NULL)
76a01679
JB
1278 {
1279 char **slot = (char **) htab_find_slot (decoded_names_store,
1280 decoded, INSERT);
5b4ee69b 1281
76a01679
JB
1282 if (*slot == NULL)
1283 *slot = xstrdup (decoded);
1284 *resultp = *slot;
1285 }
4c4b4cd2 1286 }
14f9c5c9 1287
4c4b4cd2
PH
1288 return *resultp;
1289}
76a01679 1290
2c0b251b 1291static char *
76a01679 1292ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1293{
1294 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1295}
1296
1297/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
4c4b4cd2
PH
1298 suffixes that encode debugging information or leading _ada_ on
1299 SYM_NAME (see is_name_suffix commentary for the debugging
1300 information that is ignored). If WILD, then NAME need only match a
1301 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1302 either argument is NULL. */
14f9c5c9 1303
2c0b251b 1304static int
40658b94 1305match_name (const char *sym_name, const char *name, int wild)
14f9c5c9
AS
1306{
1307 if (sym_name == NULL || name == NULL)
1308 return 0;
1309 else if (wild)
73589123 1310 return wild_match (sym_name, name) == 0;
d2e4a39e
AS
1311 else
1312 {
1313 int len_name = strlen (name);
5b4ee69b 1314
4c4b4cd2
PH
1315 return (strncmp (sym_name, name, len_name) == 0
1316 && is_name_suffix (sym_name + len_name))
1317 || (strncmp (sym_name, "_ada_", 5) == 0
1318 && strncmp (sym_name + 5, name, len_name) == 0
1319 && is_name_suffix (sym_name + len_name + 5));
d2e4a39e 1320 }
14f9c5c9 1321}
14f9c5c9 1322\f
d2e4a39e 1323
4c4b4cd2 1324 /* Arrays */
14f9c5c9 1325
28c85d6c
JB
1326/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1327 generated by the GNAT compiler to describe the index type used
1328 for each dimension of an array, check whether it follows the latest
1329 known encoding. If not, fix it up to conform to the latest encoding.
1330 Otherwise, do nothing. This function also does nothing if
1331 INDEX_DESC_TYPE is NULL.
1332
1333 The GNAT encoding used to describle the array index type evolved a bit.
1334 Initially, the information would be provided through the name of each
1335 field of the structure type only, while the type of these fields was
1336 described as unspecified and irrelevant. The debugger was then expected
1337 to perform a global type lookup using the name of that field in order
1338 to get access to the full index type description. Because these global
1339 lookups can be very expensive, the encoding was later enhanced to make
1340 the global lookup unnecessary by defining the field type as being
1341 the full index type description.
1342
1343 The purpose of this routine is to allow us to support older versions
1344 of the compiler by detecting the use of the older encoding, and by
1345 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1346 we essentially replace each field's meaningless type by the associated
1347 index subtype). */
1348
1349void
1350ada_fixup_array_indexes_type (struct type *index_desc_type)
1351{
1352 int i;
1353
1354 if (index_desc_type == NULL)
1355 return;
1356 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1357
1358 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1359 to check one field only, no need to check them all). If not, return
1360 now.
1361
1362 If our INDEX_DESC_TYPE was generated using the older encoding,
1363 the field type should be a meaningless integer type whose name
1364 is not equal to the field name. */
1365 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1366 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1367 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1368 return;
1369
1370 /* Fixup each field of INDEX_DESC_TYPE. */
1371 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1372 {
0d5cff50 1373 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1374 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1375
1376 if (raw_type)
1377 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1378 }
1379}
1380
4c4b4cd2 1381/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1382
d2e4a39e
AS
1383static char *bound_name[] = {
1384 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1385 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1386};
1387
1388/* Maximum number of array dimensions we are prepared to handle. */
1389
4c4b4cd2 1390#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1391
14f9c5c9 1392
4c4b4cd2
PH
1393/* The desc_* routines return primitive portions of array descriptors
1394 (fat pointers). */
14f9c5c9
AS
1395
1396/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1397 level of indirection, if needed. */
1398
d2e4a39e
AS
1399static struct type *
1400desc_base_type (struct type *type)
14f9c5c9
AS
1401{
1402 if (type == NULL)
1403 return NULL;
61ee279c 1404 type = ada_check_typedef (type);
720d1a40
JB
1405 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1406 type = ada_typedef_target_type (type);
1407
1265e4aa
JB
1408 if (type != NULL
1409 && (TYPE_CODE (type) == TYPE_CODE_PTR
1410 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1411 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1412 else
1413 return type;
1414}
1415
4c4b4cd2
PH
1416/* True iff TYPE indicates a "thin" array pointer type. */
1417
14f9c5c9 1418static int
d2e4a39e 1419is_thin_pntr (struct type *type)
14f9c5c9 1420{
d2e4a39e 1421 return
14f9c5c9
AS
1422 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1423 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1424}
1425
4c4b4cd2
PH
1426/* The descriptor type for thin pointer type TYPE. */
1427
d2e4a39e
AS
1428static struct type *
1429thin_descriptor_type (struct type *type)
14f9c5c9 1430{
d2e4a39e 1431 struct type *base_type = desc_base_type (type);
5b4ee69b 1432
14f9c5c9
AS
1433 if (base_type == NULL)
1434 return NULL;
1435 if (is_suffix (ada_type_name (base_type), "___XVE"))
1436 return base_type;
d2e4a39e 1437 else
14f9c5c9 1438 {
d2e4a39e 1439 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1440
14f9c5c9 1441 if (alt_type == NULL)
4c4b4cd2 1442 return base_type;
14f9c5c9 1443 else
4c4b4cd2 1444 return alt_type;
14f9c5c9
AS
1445 }
1446}
1447
4c4b4cd2
PH
1448/* A pointer to the array data for thin-pointer value VAL. */
1449
d2e4a39e
AS
1450static struct value *
1451thin_data_pntr (struct value *val)
14f9c5c9 1452{
828292f2 1453 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1454 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1455
556bdfd4
UW
1456 data_type = lookup_pointer_type (data_type);
1457
14f9c5c9 1458 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1459 return value_cast (data_type, value_copy (val));
d2e4a39e 1460 else
42ae5230 1461 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1462}
1463
4c4b4cd2
PH
1464/* True iff TYPE indicates a "thick" array pointer type. */
1465
14f9c5c9 1466static int
d2e4a39e 1467is_thick_pntr (struct type *type)
14f9c5c9
AS
1468{
1469 type = desc_base_type (type);
1470 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1471 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1472}
1473
4c4b4cd2
PH
1474/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1475 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1476
d2e4a39e
AS
1477static struct type *
1478desc_bounds_type (struct type *type)
14f9c5c9 1479{
d2e4a39e 1480 struct type *r;
14f9c5c9
AS
1481
1482 type = desc_base_type (type);
1483
1484 if (type == NULL)
1485 return NULL;
1486 else if (is_thin_pntr (type))
1487 {
1488 type = thin_descriptor_type (type);
1489 if (type == NULL)
4c4b4cd2 1490 return NULL;
14f9c5c9
AS
1491 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1492 if (r != NULL)
61ee279c 1493 return ada_check_typedef (r);
14f9c5c9
AS
1494 }
1495 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1496 {
1497 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1498 if (r != NULL)
61ee279c 1499 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1500 }
1501 return NULL;
1502}
1503
1504/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1505 one, a pointer to its bounds data. Otherwise NULL. */
1506
d2e4a39e
AS
1507static struct value *
1508desc_bounds (struct value *arr)
14f9c5c9 1509{
df407dfe 1510 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1511
d2e4a39e 1512 if (is_thin_pntr (type))
14f9c5c9 1513 {
d2e4a39e 1514 struct type *bounds_type =
4c4b4cd2 1515 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1516 LONGEST addr;
1517
4cdfadb1 1518 if (bounds_type == NULL)
323e0a4a 1519 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1520
1521 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1522 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1523 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1524 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1525 addr = value_as_long (arr);
d2e4a39e 1526 else
42ae5230 1527 addr = value_address (arr);
14f9c5c9 1528
d2e4a39e 1529 return
4c4b4cd2
PH
1530 value_from_longest (lookup_pointer_type (bounds_type),
1531 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1532 }
1533
1534 else if (is_thick_pntr (type))
05e522ef
JB
1535 {
1536 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1537 _("Bad GNAT array descriptor"));
1538 struct type *p_bounds_type = value_type (p_bounds);
1539
1540 if (p_bounds_type
1541 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1542 {
1543 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1544
1545 if (TYPE_STUB (target_type))
1546 p_bounds = value_cast (lookup_pointer_type
1547 (ada_check_typedef (target_type)),
1548 p_bounds);
1549 }
1550 else
1551 error (_("Bad GNAT array descriptor"));
1552
1553 return p_bounds;
1554 }
14f9c5c9
AS
1555 else
1556 return NULL;
1557}
1558
4c4b4cd2
PH
1559/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1560 position of the field containing the address of the bounds data. */
1561
14f9c5c9 1562static int
d2e4a39e 1563fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1564{
1565 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1566}
1567
1568/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1569 size of the field containing the address of the bounds data. */
1570
14f9c5c9 1571static int
d2e4a39e 1572fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1573{
1574 type = desc_base_type (type);
1575
d2e4a39e 1576 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1577 return TYPE_FIELD_BITSIZE (type, 1);
1578 else
61ee279c 1579 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1580}
1581
4c4b4cd2 1582/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1583 pointer to one, the type of its array data (a array-with-no-bounds type);
1584 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1585 data. */
4c4b4cd2 1586
d2e4a39e 1587static struct type *
556bdfd4 1588desc_data_target_type (struct type *type)
14f9c5c9
AS
1589{
1590 type = desc_base_type (type);
1591
4c4b4cd2 1592 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1593 if (is_thin_pntr (type))
556bdfd4 1594 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1595 else if (is_thick_pntr (type))
556bdfd4
UW
1596 {
1597 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1598
1599 if (data_type
1600 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1601 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1602 }
1603
1604 return NULL;
14f9c5c9
AS
1605}
1606
1607/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1608 its array data. */
4c4b4cd2 1609
d2e4a39e
AS
1610static struct value *
1611desc_data (struct value *arr)
14f9c5c9 1612{
df407dfe 1613 struct type *type = value_type (arr);
5b4ee69b 1614
14f9c5c9
AS
1615 if (is_thin_pntr (type))
1616 return thin_data_pntr (arr);
1617 else if (is_thick_pntr (type))
d2e4a39e 1618 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1619 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1620 else
1621 return NULL;
1622}
1623
1624
1625/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1626 position of the field containing the address of the data. */
1627
14f9c5c9 1628static int
d2e4a39e 1629fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1630{
1631 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1632}
1633
1634/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1635 size of the field containing the address of the data. */
1636
14f9c5c9 1637static int
d2e4a39e 1638fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1639{
1640 type = desc_base_type (type);
1641
1642 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1643 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1644 else
14f9c5c9
AS
1645 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1646}
1647
4c4b4cd2 1648/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1649 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1650 bound, if WHICH is 1. The first bound is I=1. */
1651
d2e4a39e
AS
1652static struct value *
1653desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1654{
d2e4a39e 1655 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1656 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1657}
1658
1659/* If BOUNDS is an array-bounds structure type, return the bit position
1660 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1661 bound, if WHICH is 1. The first bound is I=1. */
1662
14f9c5c9 1663static int
d2e4a39e 1664desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1665{
d2e4a39e 1666 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1667}
1668
1669/* If BOUNDS is an array-bounds structure type, return the bit field size
1670 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1671 bound, if WHICH is 1. The first bound is I=1. */
1672
76a01679 1673static int
d2e4a39e 1674desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1675{
1676 type = desc_base_type (type);
1677
d2e4a39e
AS
1678 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1679 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1680 else
1681 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1682}
1683
1684/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1685 Ith bound (numbering from 1). Otherwise, NULL. */
1686
d2e4a39e
AS
1687static struct type *
1688desc_index_type (struct type *type, int i)
14f9c5c9
AS
1689{
1690 type = desc_base_type (type);
1691
1692 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1693 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1694 else
14f9c5c9
AS
1695 return NULL;
1696}
1697
4c4b4cd2
PH
1698/* The number of index positions in the array-bounds type TYPE.
1699 Return 0 if TYPE is NULL. */
1700
14f9c5c9 1701static int
d2e4a39e 1702desc_arity (struct type *type)
14f9c5c9
AS
1703{
1704 type = desc_base_type (type);
1705
1706 if (type != NULL)
1707 return TYPE_NFIELDS (type) / 2;
1708 return 0;
1709}
1710
4c4b4cd2
PH
1711/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1712 an array descriptor type (representing an unconstrained array
1713 type). */
1714
76a01679
JB
1715static int
1716ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1717{
1718 if (type == NULL)
1719 return 0;
61ee279c 1720 type = ada_check_typedef (type);
4c4b4cd2 1721 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1722 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1723}
1724
52ce6436 1725/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1726 * to one. */
52ce6436 1727
2c0b251b 1728static int
52ce6436
PH
1729ada_is_array_type (struct type *type)
1730{
1731 while (type != NULL
1732 && (TYPE_CODE (type) == TYPE_CODE_PTR
1733 || TYPE_CODE (type) == TYPE_CODE_REF))
1734 type = TYPE_TARGET_TYPE (type);
1735 return ada_is_direct_array_type (type);
1736}
1737
4c4b4cd2 1738/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1739
14f9c5c9 1740int
4c4b4cd2 1741ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1742{
1743 if (type == NULL)
1744 return 0;
61ee279c 1745 type = ada_check_typedef (type);
14f9c5c9 1746 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1747 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1748 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1749 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1750}
1751
4c4b4cd2
PH
1752/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1753
14f9c5c9 1754int
4c4b4cd2 1755ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1756{
556bdfd4 1757 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1758
1759 if (type == NULL)
1760 return 0;
61ee279c 1761 type = ada_check_typedef (type);
556bdfd4
UW
1762 return (data_type != NULL
1763 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1764 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1765}
1766
1767/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1768 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1769 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1770 is still needed. */
1771
14f9c5c9 1772int
ebf56fd3 1773ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1774{
d2e4a39e 1775 return
14f9c5c9
AS
1776 type != NULL
1777 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1778 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1779 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1780 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1781}
1782
1783
4c4b4cd2 1784/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1785 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1786 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1787 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1788 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1789 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1790 a descriptor. */
d2e4a39e
AS
1791struct type *
1792ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1793{
ad82864c
JB
1794 if (ada_is_constrained_packed_array_type (value_type (arr)))
1795 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1796
df407dfe
AC
1797 if (!ada_is_array_descriptor_type (value_type (arr)))
1798 return value_type (arr);
d2e4a39e
AS
1799
1800 if (!bounds)
ad82864c
JB
1801 {
1802 struct type *array_type =
1803 ada_check_typedef (desc_data_target_type (value_type (arr)));
1804
1805 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1806 TYPE_FIELD_BITSIZE (array_type, 0) =
1807 decode_packed_array_bitsize (value_type (arr));
1808
1809 return array_type;
1810 }
14f9c5c9
AS
1811 else
1812 {
d2e4a39e 1813 struct type *elt_type;
14f9c5c9 1814 int arity;
d2e4a39e 1815 struct value *descriptor;
14f9c5c9 1816
df407dfe
AC
1817 elt_type = ada_array_element_type (value_type (arr), -1);
1818 arity = ada_array_arity (value_type (arr));
14f9c5c9 1819
d2e4a39e 1820 if (elt_type == NULL || arity == 0)
df407dfe 1821 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
1822
1823 descriptor = desc_bounds (arr);
d2e4a39e 1824 if (value_as_long (descriptor) == 0)
4c4b4cd2 1825 return NULL;
d2e4a39e 1826 while (arity > 0)
4c4b4cd2 1827 {
e9bb382b
UW
1828 struct type *range_type = alloc_type_copy (value_type (arr));
1829 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
1830 struct value *low = desc_one_bound (descriptor, arity, 0);
1831 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 1832
5b4ee69b 1833 arity -= 1;
df407dfe 1834 create_range_type (range_type, value_type (low),
529cad9c
PH
1835 longest_to_int (value_as_long (low)),
1836 longest_to_int (value_as_long (high)));
4c4b4cd2 1837 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
1838
1839 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
1840 {
1841 /* We need to store the element packed bitsize, as well as
1842 recompute the array size, because it was previously
1843 computed based on the unpacked element size. */
1844 LONGEST lo = value_as_long (low);
1845 LONGEST hi = value_as_long (high);
1846
1847 TYPE_FIELD_BITSIZE (elt_type, 0) =
1848 decode_packed_array_bitsize (value_type (arr));
1849 /* If the array has no element, then the size is already
1850 zero, and does not need to be recomputed. */
1851 if (lo < hi)
1852 {
1853 int array_bitsize =
1854 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1855
1856 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
1857 }
1858 }
4c4b4cd2 1859 }
14f9c5c9
AS
1860
1861 return lookup_pointer_type (elt_type);
1862 }
1863}
1864
1865/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
1866 Otherwise, returns either a standard GDB array with bounds set
1867 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1868 GDB array. Returns NULL if ARR is a null fat pointer. */
1869
d2e4a39e
AS
1870struct value *
1871ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 1872{
df407dfe 1873 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 1874 {
d2e4a39e 1875 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 1876
14f9c5c9 1877 if (arrType == NULL)
4c4b4cd2 1878 return NULL;
14f9c5c9
AS
1879 return value_cast (arrType, value_copy (desc_data (arr)));
1880 }
ad82864c
JB
1881 else if (ada_is_constrained_packed_array_type (value_type (arr)))
1882 return decode_constrained_packed_array (arr);
14f9c5c9
AS
1883 else
1884 return arr;
1885}
1886
1887/* If ARR does not represent an array, returns ARR unchanged.
1888 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
1889 be ARR itself if it already is in the proper form). */
1890
720d1a40 1891struct value *
d2e4a39e 1892ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 1893{
df407dfe 1894 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 1895 {
d2e4a39e 1896 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 1897
14f9c5c9 1898 if (arrVal == NULL)
323e0a4a 1899 error (_("Bounds unavailable for null array pointer."));
529cad9c 1900 check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
1901 return value_ind (arrVal);
1902 }
ad82864c
JB
1903 else if (ada_is_constrained_packed_array_type (value_type (arr)))
1904 return decode_constrained_packed_array (arr);
d2e4a39e 1905 else
14f9c5c9
AS
1906 return arr;
1907}
1908
1909/* If TYPE represents a GNAT array type, return it translated to an
1910 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
1911 packing). For other types, is the identity. */
1912
d2e4a39e
AS
1913struct type *
1914ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 1915{
ad82864c
JB
1916 if (ada_is_constrained_packed_array_type (type))
1917 return decode_constrained_packed_array_type (type);
17280b9f
UW
1918
1919 if (ada_is_array_descriptor_type (type))
556bdfd4 1920 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
1921
1922 return type;
14f9c5c9
AS
1923}
1924
4c4b4cd2
PH
1925/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1926
ad82864c
JB
1927static int
1928ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
1929{
1930 if (type == NULL)
1931 return 0;
4c4b4cd2 1932 type = desc_base_type (type);
61ee279c 1933 type = ada_check_typedef (type);
d2e4a39e 1934 return
14f9c5c9
AS
1935 ada_type_name (type) != NULL
1936 && strstr (ada_type_name (type), "___XP") != NULL;
1937}
1938
ad82864c
JB
1939/* Non-zero iff TYPE represents a standard GNAT constrained
1940 packed-array type. */
1941
1942int
1943ada_is_constrained_packed_array_type (struct type *type)
1944{
1945 return ada_is_packed_array_type (type)
1946 && !ada_is_array_descriptor_type (type);
1947}
1948
1949/* Non-zero iff TYPE represents an array descriptor for a
1950 unconstrained packed-array type. */
1951
1952static int
1953ada_is_unconstrained_packed_array_type (struct type *type)
1954{
1955 return ada_is_packed_array_type (type)
1956 && ada_is_array_descriptor_type (type);
1957}
1958
1959/* Given that TYPE encodes a packed array type (constrained or unconstrained),
1960 return the size of its elements in bits. */
1961
1962static long
1963decode_packed_array_bitsize (struct type *type)
1964{
0d5cff50
DE
1965 const char *raw_name;
1966 const char *tail;
ad82864c
JB
1967 long bits;
1968
720d1a40
JB
1969 /* Access to arrays implemented as fat pointers are encoded as a typedef
1970 of the fat pointer type. We need the name of the fat pointer type
1971 to do the decoding, so strip the typedef layer. */
1972 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1973 type = ada_typedef_target_type (type);
1974
1975 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
1976 if (!raw_name)
1977 raw_name = ada_type_name (desc_base_type (type));
1978
1979 if (!raw_name)
1980 return 0;
1981
1982 tail = strstr (raw_name, "___XP");
720d1a40 1983 gdb_assert (tail != NULL);
ad82864c
JB
1984
1985 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1986 {
1987 lim_warning
1988 (_("could not understand bit size information on packed array"));
1989 return 0;
1990 }
1991
1992 return bits;
1993}
1994
14f9c5c9
AS
1995/* Given that TYPE is a standard GDB array type with all bounds filled
1996 in, and that the element size of its ultimate scalar constituents
1997 (that is, either its elements, or, if it is an array of arrays, its
1998 elements' elements, etc.) is *ELT_BITS, return an identical type,
1999 but with the bit sizes of its elements (and those of any
2000 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2
PH
2001 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2002 in bits. */
2003
d2e4a39e 2004static struct type *
ad82864c 2005constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2006{
d2e4a39e
AS
2007 struct type *new_elt_type;
2008 struct type *new_type;
99b1c762
JB
2009 struct type *index_type_desc;
2010 struct type *index_type;
14f9c5c9
AS
2011 LONGEST low_bound, high_bound;
2012
61ee279c 2013 type = ada_check_typedef (type);
14f9c5c9
AS
2014 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2015 return type;
2016
99b1c762
JB
2017 index_type_desc = ada_find_parallel_type (type, "___XA");
2018 if (index_type_desc)
2019 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2020 NULL);
2021 else
2022 index_type = TYPE_INDEX_TYPE (type);
2023
e9bb382b 2024 new_type = alloc_type_copy (type);
ad82864c
JB
2025 new_elt_type =
2026 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2027 elt_bits);
99b1c762 2028 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2029 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2030 TYPE_NAME (new_type) = ada_type_name (type);
2031
99b1c762 2032 if (get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2033 low_bound = high_bound = 0;
2034 if (high_bound < low_bound)
2035 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2036 else
14f9c5c9
AS
2037 {
2038 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2039 TYPE_LENGTH (new_type) =
4c4b4cd2 2040 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2041 }
2042
876cecd0 2043 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2044 return new_type;
2045}
2046
ad82864c
JB
2047/* The array type encoded by TYPE, where
2048 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2049
d2e4a39e 2050static struct type *
ad82864c 2051decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2052{
0d5cff50 2053 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2054 char *name;
0d5cff50 2055 const char *tail;
d2e4a39e 2056 struct type *shadow_type;
14f9c5c9 2057 long bits;
14f9c5c9 2058
727e3d2e
JB
2059 if (!raw_name)
2060 raw_name = ada_type_name (desc_base_type (type));
2061
2062 if (!raw_name)
2063 return NULL;
2064
2065 name = (char *) alloca (strlen (raw_name) + 1);
2066 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2067 type = desc_base_type (type);
2068
14f9c5c9
AS
2069 memcpy (name, raw_name, tail - raw_name);
2070 name[tail - raw_name] = '\000';
2071
b4ba55a1
JB
2072 shadow_type = ada_find_parallel_type_with_name (type, name);
2073
2074 if (shadow_type == NULL)
14f9c5c9 2075 {
323e0a4a 2076 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2077 return NULL;
2078 }
cb249c71 2079 CHECK_TYPEDEF (shadow_type);
14f9c5c9
AS
2080
2081 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2082 {
0963b4bd
MS
2083 lim_warning (_("could not understand bounds "
2084 "information on packed array"));
14f9c5c9
AS
2085 return NULL;
2086 }
d2e4a39e 2087
ad82864c
JB
2088 bits = decode_packed_array_bitsize (type);
2089 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2090}
2091
ad82864c
JB
2092/* Given that ARR is a struct value *indicating a GNAT constrained packed
2093 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2094 standard GDB array type except that the BITSIZEs of the array
2095 target types are set to the number of bits in each element, and the
4c4b4cd2 2096 type length is set appropriately. */
14f9c5c9 2097
d2e4a39e 2098static struct value *
ad82864c 2099decode_constrained_packed_array (struct value *arr)
14f9c5c9 2100{
4c4b4cd2 2101 struct type *type;
14f9c5c9 2102
4c4b4cd2 2103 arr = ada_coerce_ref (arr);
284614f0
JB
2104
2105 /* If our value is a pointer, then dererence it. Make sure that
2106 this operation does not cause the target type to be fixed, as
2107 this would indirectly cause this array to be decoded. The rest
2108 of the routine assumes that the array hasn't been decoded yet,
2109 so we use the basic "value_ind" routine to perform the dereferencing,
2110 as opposed to using "ada_value_ind". */
828292f2 2111 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2112 arr = value_ind (arr);
4c4b4cd2 2113
ad82864c 2114 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2115 if (type == NULL)
2116 {
323e0a4a 2117 error (_("can't unpack array"));
14f9c5c9
AS
2118 return NULL;
2119 }
61ee279c 2120
50810684 2121 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2122 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2123 {
2124 /* This is a (right-justified) modular type representing a packed
2125 array with no wrapper. In order to interpret the value through
2126 the (left-justified) packed array type we just built, we must
2127 first left-justify it. */
2128 int bit_size, bit_pos;
2129 ULONGEST mod;
2130
df407dfe 2131 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2132 bit_size = 0;
2133 while (mod > 0)
2134 {
2135 bit_size += 1;
2136 mod >>= 1;
2137 }
df407dfe 2138 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2139 arr = ada_value_primitive_packed_val (arr, NULL,
2140 bit_pos / HOST_CHAR_BIT,
2141 bit_pos % HOST_CHAR_BIT,
2142 bit_size,
2143 type);
2144 }
2145
4c4b4cd2 2146 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2147}
2148
2149
2150/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2151 given in IND. ARR must be a simple array. */
14f9c5c9 2152
d2e4a39e
AS
2153static struct value *
2154value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2155{
2156 int i;
2157 int bits, elt_off, bit_off;
2158 long elt_total_bit_offset;
d2e4a39e
AS
2159 struct type *elt_type;
2160 struct value *v;
14f9c5c9
AS
2161
2162 bits = 0;
2163 elt_total_bit_offset = 0;
df407dfe 2164 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2165 for (i = 0; i < arity; i += 1)
14f9c5c9 2166 {
d2e4a39e 2167 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2168 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2169 error
0963b4bd
MS
2170 (_("attempt to do packed indexing of "
2171 "something other than a packed array"));
14f9c5c9 2172 else
4c4b4cd2
PH
2173 {
2174 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2175 LONGEST lowerbound, upperbound;
2176 LONGEST idx;
2177
2178 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2179 {
323e0a4a 2180 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2181 lowerbound = upperbound = 0;
2182 }
2183
3cb382c9 2184 idx = pos_atr (ind[i]);
4c4b4cd2 2185 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2186 lim_warning (_("packed array index %ld out of bounds"),
2187 (long) idx);
4c4b4cd2
PH
2188 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2189 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2190 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2191 }
14f9c5c9
AS
2192 }
2193 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2194 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2195
2196 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2197 bits, elt_type);
14f9c5c9
AS
2198 return v;
2199}
2200
4c4b4cd2 2201/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2202
2203static int
d2e4a39e 2204has_negatives (struct type *type)
14f9c5c9 2205{
d2e4a39e
AS
2206 switch (TYPE_CODE (type))
2207 {
2208 default:
2209 return 0;
2210 case TYPE_CODE_INT:
2211 return !TYPE_UNSIGNED (type);
2212 case TYPE_CODE_RANGE:
2213 return TYPE_LOW_BOUND (type) < 0;
2214 }
14f9c5c9 2215}
d2e4a39e 2216
14f9c5c9
AS
2217
2218/* Create a new value of type TYPE from the contents of OBJ starting
2219 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2220 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
0963b4bd 2221 assigning through the result will set the field fetched from.
4c4b4cd2
PH
2222 VALADDR is ignored unless OBJ is NULL, in which case,
2223 VALADDR+OFFSET must address the start of storage containing the
2224 packed value. The value returned in this case is never an lval.
2225 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
14f9c5c9 2226
d2e4a39e 2227struct value *
fc1a4b47 2228ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
a2bd3dcd 2229 long offset, int bit_offset, int bit_size,
4c4b4cd2 2230 struct type *type)
14f9c5c9 2231{
d2e4a39e 2232 struct value *v;
4c4b4cd2
PH
2233 int src, /* Index into the source area */
2234 targ, /* Index into the target area */
2235 srcBitsLeft, /* Number of source bits left to move */
2236 nsrc, ntarg, /* Number of source and target bytes */
2237 unusedLS, /* Number of bits in next significant
2238 byte of source that are unused */
2239 accumSize; /* Number of meaningful bits in accum */
2240 unsigned char *bytes; /* First byte containing data to unpack */
d2e4a39e 2241 unsigned char *unpacked;
4c4b4cd2 2242 unsigned long accum; /* Staging area for bits being transferred */
14f9c5c9
AS
2243 unsigned char sign;
2244 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
4c4b4cd2
PH
2245 /* Transmit bytes from least to most significant; delta is the direction
2246 the indices move. */
50810684 2247 int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1;
14f9c5c9 2248
61ee279c 2249 type = ada_check_typedef (type);
14f9c5c9
AS
2250
2251 if (obj == NULL)
2252 {
2253 v = allocate_value (type);
d2e4a39e 2254 bytes = (unsigned char *) (valaddr + offset);
14f9c5c9 2255 }
9214ee5f 2256 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
14f9c5c9
AS
2257 {
2258 v = value_at (type,
42ae5230 2259 value_address (obj) + offset);
d2e4a39e 2260 bytes = (unsigned char *) alloca (len);
42ae5230 2261 read_memory (value_address (v), bytes, len);
14f9c5c9 2262 }
d2e4a39e 2263 else
14f9c5c9
AS
2264 {
2265 v = allocate_value (type);
0fd88904 2266 bytes = (unsigned char *) value_contents (obj) + offset;
14f9c5c9 2267 }
d2e4a39e
AS
2268
2269 if (obj != NULL)
14f9c5c9 2270 {
42ae5230 2271 CORE_ADDR new_addr;
5b4ee69b 2272
74bcbdf3 2273 set_value_component_location (v, obj);
42ae5230 2274 new_addr = value_address (obj) + offset;
9bbda503
AC
2275 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2276 set_value_bitsize (v, bit_size);
df407dfe 2277 if (value_bitpos (v) >= HOST_CHAR_BIT)
4c4b4cd2 2278 {
42ae5230 2279 ++new_addr;
9bbda503 2280 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
4c4b4cd2 2281 }
42ae5230 2282 set_value_address (v, new_addr);
14f9c5c9
AS
2283 }
2284 else
9bbda503 2285 set_value_bitsize (v, bit_size);
0fd88904 2286 unpacked = (unsigned char *) value_contents (v);
14f9c5c9
AS
2287
2288 srcBitsLeft = bit_size;
2289 nsrc = len;
2290 ntarg = TYPE_LENGTH (type);
2291 sign = 0;
2292 if (bit_size == 0)
2293 {
2294 memset (unpacked, 0, TYPE_LENGTH (type));
2295 return v;
2296 }
50810684 2297 else if (gdbarch_bits_big_endian (get_type_arch (type)))
14f9c5c9 2298 {
d2e4a39e 2299 src = len - 1;
1265e4aa
JB
2300 if (has_negatives (type)
2301 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2302 sign = ~0;
d2e4a39e
AS
2303
2304 unusedLS =
4c4b4cd2
PH
2305 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2306 % HOST_CHAR_BIT;
14f9c5c9
AS
2307
2308 switch (TYPE_CODE (type))
4c4b4cd2
PH
2309 {
2310 case TYPE_CODE_ARRAY:
2311 case TYPE_CODE_UNION:
2312 case TYPE_CODE_STRUCT:
2313 /* Non-scalar values must be aligned at a byte boundary... */
2314 accumSize =
2315 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2316 /* ... And are placed at the beginning (most-significant) bytes
2317 of the target. */
529cad9c 2318 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
0056e4d5 2319 ntarg = targ + 1;
4c4b4cd2
PH
2320 break;
2321 default:
2322 accumSize = 0;
2323 targ = TYPE_LENGTH (type) - 1;
2324 break;
2325 }
14f9c5c9 2326 }
d2e4a39e 2327 else
14f9c5c9
AS
2328 {
2329 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2330
2331 src = targ = 0;
2332 unusedLS = bit_offset;
2333 accumSize = 0;
2334
d2e4a39e 2335 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2336 sign = ~0;
14f9c5c9 2337 }
d2e4a39e 2338
14f9c5c9
AS
2339 accum = 0;
2340 while (nsrc > 0)
2341 {
2342 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2343 part of the value. */
d2e4a39e 2344 unsigned int unusedMSMask =
4c4b4cd2
PH
2345 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2346 1;
2347 /* Sign-extend bits for this byte. */
14f9c5c9 2348 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2349
d2e4a39e 2350 accum |=
4c4b4cd2 2351 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2352 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2353 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2
PH
2354 {
2355 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2356 accumSize -= HOST_CHAR_BIT;
2357 accum >>= HOST_CHAR_BIT;
2358 ntarg -= 1;
2359 targ += delta;
2360 }
14f9c5c9
AS
2361 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2362 unusedLS = 0;
2363 nsrc -= 1;
2364 src += delta;
2365 }
2366 while (ntarg > 0)
2367 {
2368 accum |= sign << accumSize;
2369 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2370 accumSize -= HOST_CHAR_BIT;
2371 accum >>= HOST_CHAR_BIT;
2372 ntarg -= 1;
2373 targ += delta;
2374 }
2375
2376 return v;
2377}
d2e4a39e 2378
14f9c5c9
AS
2379/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2380 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2381 not overlap. */
14f9c5c9 2382static void
fc1a4b47 2383move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2384 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2385{
2386 unsigned int accum, mask;
2387 int accum_bits, chunk_size;
2388
2389 target += targ_offset / HOST_CHAR_BIT;
2390 targ_offset %= HOST_CHAR_BIT;
2391 source += src_offset / HOST_CHAR_BIT;
2392 src_offset %= HOST_CHAR_BIT;
50810684 2393 if (bits_big_endian_p)
14f9c5c9
AS
2394 {
2395 accum = (unsigned char) *source;
2396 source += 1;
2397 accum_bits = HOST_CHAR_BIT - src_offset;
2398
d2e4a39e 2399 while (n > 0)
4c4b4cd2
PH
2400 {
2401 int unused_right;
5b4ee69b 2402
4c4b4cd2
PH
2403 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2404 accum_bits += HOST_CHAR_BIT;
2405 source += 1;
2406 chunk_size = HOST_CHAR_BIT - targ_offset;
2407 if (chunk_size > n)
2408 chunk_size = n;
2409 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2410 mask = ((1 << chunk_size) - 1) << unused_right;
2411 *target =
2412 (*target & ~mask)
2413 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2414 n -= chunk_size;
2415 accum_bits -= chunk_size;
2416 target += 1;
2417 targ_offset = 0;
2418 }
14f9c5c9
AS
2419 }
2420 else
2421 {
2422 accum = (unsigned char) *source >> src_offset;
2423 source += 1;
2424 accum_bits = HOST_CHAR_BIT - src_offset;
2425
d2e4a39e 2426 while (n > 0)
4c4b4cd2
PH
2427 {
2428 accum = accum + ((unsigned char) *source << accum_bits);
2429 accum_bits += HOST_CHAR_BIT;
2430 source += 1;
2431 chunk_size = HOST_CHAR_BIT - targ_offset;
2432 if (chunk_size > n)
2433 chunk_size = n;
2434 mask = ((1 << chunk_size) - 1) << targ_offset;
2435 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2436 n -= chunk_size;
2437 accum_bits -= chunk_size;
2438 accum >>= chunk_size;
2439 target += 1;
2440 targ_offset = 0;
2441 }
14f9c5c9
AS
2442 }
2443}
2444
14f9c5c9
AS
2445/* Store the contents of FROMVAL into the location of TOVAL.
2446 Return a new value with the location of TOVAL and contents of
2447 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2448 floating-point or non-scalar types. */
14f9c5c9 2449
d2e4a39e
AS
2450static struct value *
2451ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2452{
df407dfe
AC
2453 struct type *type = value_type (toval);
2454 int bits = value_bitsize (toval);
14f9c5c9 2455
52ce6436
PH
2456 toval = ada_coerce_ref (toval);
2457 fromval = ada_coerce_ref (fromval);
2458
2459 if (ada_is_direct_array_type (value_type (toval)))
2460 toval = ada_coerce_to_simple_array (toval);
2461 if (ada_is_direct_array_type (value_type (fromval)))
2462 fromval = ada_coerce_to_simple_array (fromval);
2463
88e3b34b 2464 if (!deprecated_value_modifiable (toval))
323e0a4a 2465 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2466
d2e4a39e 2467 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2468 && bits > 0
d2e4a39e 2469 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2470 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2471 {
df407dfe
AC
2472 int len = (value_bitpos (toval)
2473 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2474 int from_size;
d2e4a39e
AS
2475 char *buffer = (char *) alloca (len);
2476 struct value *val;
42ae5230 2477 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2478
2479 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2480 fromval = value_cast (type, fromval);
14f9c5c9 2481
52ce6436 2482 read_memory (to_addr, buffer, len);
aced2898
PH
2483 from_size = value_bitsize (fromval);
2484 if (from_size == 0)
2485 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2486 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2487 move_bits (buffer, value_bitpos (toval),
50810684 2488 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2489 else
50810684
UW
2490 move_bits (buffer, value_bitpos (toval),
2491 value_contents (fromval), 0, bits, 0);
52ce6436 2492 write_memory (to_addr, buffer, len);
8cebebb9
PP
2493 observer_notify_memory_changed (to_addr, len, buffer);
2494
14f9c5c9 2495 val = value_copy (toval);
0fd88904 2496 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2497 TYPE_LENGTH (type));
04624583 2498 deprecated_set_value_type (val, type);
d2e4a39e 2499
14f9c5c9
AS
2500 return val;
2501 }
2502
2503 return value_assign (toval, fromval);
2504}
2505
2506
52ce6436
PH
2507/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2508 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2509 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2510 * COMPONENT, and not the inferior's memory. The current contents
2511 * of COMPONENT are ignored. */
2512static void
2513value_assign_to_component (struct value *container, struct value *component,
2514 struct value *val)
2515{
2516 LONGEST offset_in_container =
42ae5230 2517 (LONGEST) (value_address (component) - value_address (container));
52ce6436
PH
2518 int bit_offset_in_container =
2519 value_bitpos (component) - value_bitpos (container);
2520 int bits;
2521
2522 val = value_cast (value_type (component), val);
2523
2524 if (value_bitsize (component) == 0)
2525 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2526 else
2527 bits = value_bitsize (component);
2528
50810684 2529 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
52ce6436
PH
2530 move_bits (value_contents_writeable (container) + offset_in_container,
2531 value_bitpos (container) + bit_offset_in_container,
2532 value_contents (val),
2533 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
50810684 2534 bits, 1);
52ce6436
PH
2535 else
2536 move_bits (value_contents_writeable (container) + offset_in_container,
2537 value_bitpos (container) + bit_offset_in_container,
50810684 2538 value_contents (val), 0, bits, 0);
52ce6436
PH
2539}
2540
4c4b4cd2
PH
2541/* The value of the element of array ARR at the ARITY indices given in IND.
2542 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2543 thereto. */
2544
d2e4a39e
AS
2545struct value *
2546ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2547{
2548 int k;
d2e4a39e
AS
2549 struct value *elt;
2550 struct type *elt_type;
14f9c5c9
AS
2551
2552 elt = ada_coerce_to_simple_array (arr);
2553
df407dfe 2554 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2555 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2556 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2557 return value_subscript_packed (elt, arity, ind);
2558
2559 for (k = 0; k < arity; k += 1)
2560 {
2561 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2562 error (_("too many subscripts (%d expected)"), k);
2497b498 2563 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2564 }
2565 return elt;
2566}
2567
2568/* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2569 value of the element of *ARR at the ARITY indices given in
4c4b4cd2 2570 IND. Does not read the entire array into memory. */
14f9c5c9 2571
2c0b251b 2572static struct value *
d2e4a39e 2573ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
4c4b4cd2 2574 struct value **ind)
14f9c5c9
AS
2575{
2576 int k;
2577
2578 for (k = 0; k < arity; k += 1)
2579 {
2580 LONGEST lwb, upb;
14f9c5c9
AS
2581
2582 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2583 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2584 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2585 value_copy (arr));
14f9c5c9 2586 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2497b498 2587 arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
14f9c5c9
AS
2588 type = TYPE_TARGET_TYPE (type);
2589 }
2590
2591 return value_ind (arr);
2592}
2593
0b5d8877 2594/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
f5938064
JG
2595 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2596 elements starting at index LOW. The lower bound of this array is LOW, as
0963b4bd 2597 per Ada rules. */
0b5d8877 2598static struct value *
f5938064
JG
2599ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2600 int low, int high)
0b5d8877 2601{
b0dd7688 2602 struct type *type0 = ada_check_typedef (type);
6c038f32 2603 CORE_ADDR base = value_as_address (array_ptr)
b0dd7688
JB
2604 + ((low - ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0)))
2605 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
6c038f32 2606 struct type *index_type =
b0dd7688 2607 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)),
0b5d8877 2608 low, high);
6c038f32 2609 struct type *slice_type =
b0dd7688 2610 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
5b4ee69b 2611
f5938064 2612 return value_at_lazy (slice_type, base);
0b5d8877
PH
2613}
2614
2615
2616static struct value *
2617ada_value_slice (struct value *array, int low, int high)
2618{
b0dd7688 2619 struct type *type = ada_check_typedef (value_type (array));
6c038f32 2620 struct type *index_type =
0b5d8877 2621 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
6c038f32 2622 struct type *slice_type =
0b5d8877 2623 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
5b4ee69b 2624
6c038f32 2625 return value_cast (slice_type, value_slice (array, low, high - low + 1));
0b5d8877
PH
2626}
2627
14f9c5c9
AS
2628/* If type is a record type in the form of a standard GNAT array
2629 descriptor, returns the number of dimensions for type. If arr is a
2630 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2631 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2632
2633int
d2e4a39e 2634ada_array_arity (struct type *type)
14f9c5c9
AS
2635{
2636 int arity;
2637
2638 if (type == NULL)
2639 return 0;
2640
2641 type = desc_base_type (type);
2642
2643 arity = 0;
d2e4a39e 2644 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2645 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2646 else
2647 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2648 {
4c4b4cd2 2649 arity += 1;
61ee279c 2650 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2651 }
d2e4a39e 2652
14f9c5c9
AS
2653 return arity;
2654}
2655
2656/* If TYPE is a record type in the form of a standard GNAT array
2657 descriptor or a simple array type, returns the element type for
2658 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2659 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2660
d2e4a39e
AS
2661struct type *
2662ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2663{
2664 type = desc_base_type (type);
2665
d2e4a39e 2666 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2667 {
2668 int k;
d2e4a39e 2669 struct type *p_array_type;
14f9c5c9 2670
556bdfd4 2671 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
2672
2673 k = ada_array_arity (type);
2674 if (k == 0)
4c4b4cd2 2675 return NULL;
d2e4a39e 2676
4c4b4cd2 2677 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2678 if (nindices >= 0 && k > nindices)
4c4b4cd2 2679 k = nindices;
d2e4a39e 2680 while (k > 0 && p_array_type != NULL)
4c4b4cd2 2681 {
61ee279c 2682 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
2683 k -= 1;
2684 }
14f9c5c9
AS
2685 return p_array_type;
2686 }
2687 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2688 {
2689 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
2690 {
2691 type = TYPE_TARGET_TYPE (type);
2692 nindices -= 1;
2693 }
14f9c5c9
AS
2694 return type;
2695 }
2696
2697 return NULL;
2698}
2699
4c4b4cd2 2700/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
2701 Does not examine memory. Throws an error if N is invalid or TYPE
2702 is not an array type. NAME is the name of the Ada attribute being
2703 evaluated ('range, 'first, 'last, or 'length); it is used in building
2704 the error message. */
14f9c5c9 2705
1eea4ebd
UW
2706static struct type *
2707ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 2708{
4c4b4cd2
PH
2709 struct type *result_type;
2710
14f9c5c9
AS
2711 type = desc_base_type (type);
2712
1eea4ebd
UW
2713 if (n < 0 || n > ada_array_arity (type))
2714 error (_("invalid dimension number to '%s"), name);
14f9c5c9 2715
4c4b4cd2 2716 if (ada_is_simple_array_type (type))
14f9c5c9
AS
2717 {
2718 int i;
2719
2720 for (i = 1; i < n; i += 1)
4c4b4cd2 2721 type = TYPE_TARGET_TYPE (type);
262452ec 2722 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
2723 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2724 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 2725 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
2726 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2727 result_type = NULL;
14f9c5c9 2728 }
d2e4a39e 2729 else
1eea4ebd
UW
2730 {
2731 result_type = desc_index_type (desc_bounds_type (type), n);
2732 if (result_type == NULL)
2733 error (_("attempt to take bound of something that is not an array"));
2734 }
2735
2736 return result_type;
14f9c5c9
AS
2737}
2738
2739/* Given that arr is an array type, returns the lower bound of the
2740 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 2741 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
2742 array-descriptor type. It works for other arrays with bounds supplied
2743 by run-time quantities other than discriminants. */
14f9c5c9 2744
abb68b3e 2745static LONGEST
1eea4ebd 2746ada_array_bound_from_type (struct type * arr_type, int n, int which)
14f9c5c9 2747{
1ce677a4 2748 struct type *type, *elt_type, *index_type_desc, *index_type;
1ce677a4 2749 int i;
262452ec
JK
2750
2751 gdb_assert (which == 0 || which == 1);
14f9c5c9 2752
ad82864c
JB
2753 if (ada_is_constrained_packed_array_type (arr_type))
2754 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 2755
4c4b4cd2 2756 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 2757 return (LONGEST) - which;
14f9c5c9
AS
2758
2759 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2760 type = TYPE_TARGET_TYPE (arr_type);
2761 else
2762 type = arr_type;
2763
1ce677a4
UW
2764 elt_type = type;
2765 for (i = n; i > 1; i--)
2766 elt_type = TYPE_TARGET_TYPE (type);
2767
14f9c5c9 2768 index_type_desc = ada_find_parallel_type (type, "___XA");
28c85d6c 2769 ada_fixup_array_indexes_type (index_type_desc);
262452ec 2770 if (index_type_desc != NULL)
28c85d6c
JB
2771 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
2772 NULL);
262452ec 2773 else
1ce677a4 2774 index_type = TYPE_INDEX_TYPE (elt_type);
262452ec 2775
43bbcdc2
PH
2776 return
2777 (LONGEST) (which == 0
2778 ? ada_discrete_type_low_bound (index_type)
2779 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
2780}
2781
2782/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
2783 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2784 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 2785 supplied by run-time quantities other than discriminants. */
14f9c5c9 2786
1eea4ebd 2787static LONGEST
4dc81987 2788ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 2789{
df407dfe 2790 struct type *arr_type = value_type (arr);
14f9c5c9 2791
ad82864c
JB
2792 if (ada_is_constrained_packed_array_type (arr_type))
2793 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 2794 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 2795 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 2796 else
1eea4ebd 2797 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
2798}
2799
2800/* Given that arr is an array value, returns the length of the
2801 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
2802 supplied by run-time quantities other than discriminants.
2803 Does not work for arrays indexed by enumeration types with representation
2804 clauses at the moment. */
14f9c5c9 2805
1eea4ebd 2806static LONGEST
d2e4a39e 2807ada_array_length (struct value *arr, int n)
14f9c5c9 2808{
df407dfe 2809 struct type *arr_type = ada_check_typedef (value_type (arr));
14f9c5c9 2810
ad82864c
JB
2811 if (ada_is_constrained_packed_array_type (arr_type))
2812 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 2813
4c4b4cd2 2814 if (ada_is_simple_array_type (arr_type))
1eea4ebd
UW
2815 return (ada_array_bound_from_type (arr_type, n, 1)
2816 - ada_array_bound_from_type (arr_type, n, 0) + 1);
14f9c5c9 2817 else
1eea4ebd
UW
2818 return (value_as_long (desc_one_bound (desc_bounds (arr), n, 1))
2819 - value_as_long (desc_one_bound (desc_bounds (arr), n, 0)) + 1);
4c4b4cd2
PH
2820}
2821
2822/* An empty array whose type is that of ARR_TYPE (an array type),
2823 with bounds LOW to LOW-1. */
2824
2825static struct value *
2826empty_array (struct type *arr_type, int low)
2827{
b0dd7688 2828 struct type *arr_type0 = ada_check_typedef (arr_type);
6c038f32 2829 struct type *index_type =
b0dd7688 2830 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)),
0b5d8877 2831 low, low - 1);
b0dd7688 2832 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 2833
0b5d8877 2834 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 2835}
14f9c5c9 2836\f
d2e4a39e 2837
4c4b4cd2 2838 /* Name resolution */
14f9c5c9 2839
4c4b4cd2
PH
2840/* The "decoded" name for the user-definable Ada operator corresponding
2841 to OP. */
14f9c5c9 2842
d2e4a39e 2843static const char *
4c4b4cd2 2844ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
2845{
2846 int i;
2847
4c4b4cd2 2848 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
2849 {
2850 if (ada_opname_table[i].op == op)
4c4b4cd2 2851 return ada_opname_table[i].decoded;
14f9c5c9 2852 }
323e0a4a 2853 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
2854}
2855
2856
4c4b4cd2
PH
2857/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2858 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2859 undefined namespace) and converts operators that are
2860 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
2861 non-null, it provides a preferred result type [at the moment, only
2862 type void has any effect---causing procedures to be preferred over
2863 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 2864 return type is preferred. May change (expand) *EXP. */
14f9c5c9 2865
4c4b4cd2
PH
2866static void
2867resolve (struct expression **expp, int void_context_p)
14f9c5c9 2868{
30b15541
UW
2869 struct type *context_type = NULL;
2870 int pc = 0;
2871
2872 if (void_context_p)
2873 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
2874
2875 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
2876}
2877
4c4b4cd2
PH
2878/* Resolve the operator of the subexpression beginning at
2879 position *POS of *EXPP. "Resolving" consists of replacing
2880 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2881 with their resolutions, replacing built-in operators with
2882 function calls to user-defined operators, where appropriate, and,
2883 when DEPROCEDURE_P is non-zero, converting function-valued variables
2884 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2885 are as in ada_resolve, above. */
14f9c5c9 2886
d2e4a39e 2887static struct value *
4c4b4cd2 2888resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
76a01679 2889 struct type *context_type)
14f9c5c9
AS
2890{
2891 int pc = *pos;
2892 int i;
4c4b4cd2 2893 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 2894 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
2895 struct value **argvec; /* Vector of operand types (alloca'ed). */
2896 int nargs; /* Number of operands. */
52ce6436 2897 int oplen;
14f9c5c9
AS
2898
2899 argvec = NULL;
2900 nargs = 0;
2901 exp = *expp;
2902
52ce6436
PH
2903 /* Pass one: resolve operands, saving their types and updating *pos,
2904 if needed. */
14f9c5c9
AS
2905 switch (op)
2906 {
4c4b4cd2
PH
2907 case OP_FUNCALL:
2908 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
2909 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2910 *pos += 7;
4c4b4cd2
PH
2911 else
2912 {
2913 *pos += 3;
2914 resolve_subexp (expp, pos, 0, NULL);
2915 }
2916 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
2917 break;
2918
14f9c5c9 2919 case UNOP_ADDR:
4c4b4cd2
PH
2920 *pos += 1;
2921 resolve_subexp (expp, pos, 0, NULL);
2922 break;
2923
52ce6436
PH
2924 case UNOP_QUAL:
2925 *pos += 3;
17466c1a 2926 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
2927 break;
2928
52ce6436 2929 case OP_ATR_MODULUS:
4c4b4cd2
PH
2930 case OP_ATR_SIZE:
2931 case OP_ATR_TAG:
4c4b4cd2
PH
2932 case OP_ATR_FIRST:
2933 case OP_ATR_LAST:
2934 case OP_ATR_LENGTH:
2935 case OP_ATR_POS:
2936 case OP_ATR_VAL:
4c4b4cd2
PH
2937 case OP_ATR_MIN:
2938 case OP_ATR_MAX:
52ce6436
PH
2939 case TERNOP_IN_RANGE:
2940 case BINOP_IN_BOUNDS:
2941 case UNOP_IN_RANGE:
2942 case OP_AGGREGATE:
2943 case OP_OTHERS:
2944 case OP_CHOICES:
2945 case OP_POSITIONAL:
2946 case OP_DISCRETE_RANGE:
2947 case OP_NAME:
2948 ada_forward_operator_length (exp, pc, &oplen, &nargs);
2949 *pos += oplen;
14f9c5c9
AS
2950 break;
2951
2952 case BINOP_ASSIGN:
2953 {
4c4b4cd2
PH
2954 struct value *arg1;
2955
2956 *pos += 1;
2957 arg1 = resolve_subexp (expp, pos, 0, NULL);
2958 if (arg1 == NULL)
2959 resolve_subexp (expp, pos, 1, NULL);
2960 else
df407dfe 2961 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 2962 break;
14f9c5c9
AS
2963 }
2964
4c4b4cd2 2965 case UNOP_CAST:
4c4b4cd2
PH
2966 *pos += 3;
2967 nargs = 1;
2968 break;
14f9c5c9 2969
4c4b4cd2
PH
2970 case BINOP_ADD:
2971 case BINOP_SUB:
2972 case BINOP_MUL:
2973 case BINOP_DIV:
2974 case BINOP_REM:
2975 case BINOP_MOD:
2976 case BINOP_EXP:
2977 case BINOP_CONCAT:
2978 case BINOP_LOGICAL_AND:
2979 case BINOP_LOGICAL_OR:
2980 case BINOP_BITWISE_AND:
2981 case BINOP_BITWISE_IOR:
2982 case BINOP_BITWISE_XOR:
14f9c5c9 2983
4c4b4cd2
PH
2984 case BINOP_EQUAL:
2985 case BINOP_NOTEQUAL:
2986 case BINOP_LESS:
2987 case BINOP_GTR:
2988 case BINOP_LEQ:
2989 case BINOP_GEQ:
14f9c5c9 2990
4c4b4cd2
PH
2991 case BINOP_REPEAT:
2992 case BINOP_SUBSCRIPT:
2993 case BINOP_COMMA:
40c8aaa9
JB
2994 *pos += 1;
2995 nargs = 2;
2996 break;
14f9c5c9 2997
4c4b4cd2
PH
2998 case UNOP_NEG:
2999 case UNOP_PLUS:
3000 case UNOP_LOGICAL_NOT:
3001 case UNOP_ABS:
3002 case UNOP_IND:
3003 *pos += 1;
3004 nargs = 1;
3005 break;
14f9c5c9 3006
4c4b4cd2
PH
3007 case OP_LONG:
3008 case OP_DOUBLE:
3009 case OP_VAR_VALUE:
3010 *pos += 4;
3011 break;
14f9c5c9 3012
4c4b4cd2
PH
3013 case OP_TYPE:
3014 case OP_BOOL:
3015 case OP_LAST:
4c4b4cd2
PH
3016 case OP_INTERNALVAR:
3017 *pos += 3;
3018 break;
14f9c5c9 3019
4c4b4cd2
PH
3020 case UNOP_MEMVAL:
3021 *pos += 3;
3022 nargs = 1;
3023 break;
3024
67f3407f
DJ
3025 case OP_REGISTER:
3026 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3027 break;
3028
4c4b4cd2
PH
3029 case STRUCTOP_STRUCT:
3030 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3031 nargs = 1;
3032 break;
3033
4c4b4cd2 3034 case TERNOP_SLICE:
4c4b4cd2
PH
3035 *pos += 1;
3036 nargs = 3;
3037 break;
3038
52ce6436 3039 case OP_STRING:
14f9c5c9 3040 break;
4c4b4cd2
PH
3041
3042 default:
323e0a4a 3043 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3044 }
3045
76a01679 3046 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
4c4b4cd2
PH
3047 for (i = 0; i < nargs; i += 1)
3048 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3049 argvec[i] = NULL;
3050 exp = *expp;
3051
3052 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3053 switch (op)
3054 {
3055 default:
3056 break;
3057
14f9c5c9 3058 case OP_VAR_VALUE:
4c4b4cd2 3059 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
3060 {
3061 struct ada_symbol_info *candidates;
3062 int n_candidates;
3063
3064 n_candidates =
3065 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3066 (exp->elts[pc + 2].symbol),
3067 exp->elts[pc + 1].block, VAR_DOMAIN,
d9680e73 3068 &candidates, 1);
76a01679
JB
3069
3070 if (n_candidates > 1)
3071 {
3072 /* Types tend to get re-introduced locally, so if there
3073 are any local symbols that are not types, first filter
3074 out all types. */
3075 int j;
3076 for (j = 0; j < n_candidates; j += 1)
3077 switch (SYMBOL_CLASS (candidates[j].sym))
3078 {
3079 case LOC_REGISTER:
3080 case LOC_ARG:
3081 case LOC_REF_ARG:
76a01679
JB
3082 case LOC_REGPARM_ADDR:
3083 case LOC_LOCAL:
76a01679 3084 case LOC_COMPUTED:
76a01679
JB
3085 goto FoundNonType;
3086 default:
3087 break;
3088 }
3089 FoundNonType:
3090 if (j < n_candidates)
3091 {
3092 j = 0;
3093 while (j < n_candidates)
3094 {
3095 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
3096 {
3097 candidates[j] = candidates[n_candidates - 1];
3098 n_candidates -= 1;
3099 }
3100 else
3101 j += 1;
3102 }
3103 }
3104 }
3105
3106 if (n_candidates == 0)
323e0a4a 3107 error (_("No definition found for %s"),
76a01679
JB
3108 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3109 else if (n_candidates == 1)
3110 i = 0;
3111 else if (deprocedure_p
3112 && !is_nonfunction (candidates, n_candidates))
3113 {
06d5cf63
JB
3114 i = ada_resolve_function
3115 (candidates, n_candidates, NULL, 0,
3116 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3117 context_type);
76a01679 3118 if (i < 0)
323e0a4a 3119 error (_("Could not find a match for %s"),
76a01679
JB
3120 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3121 }
3122 else
3123 {
323e0a4a 3124 printf_filtered (_("Multiple matches for %s\n"),
76a01679
JB
3125 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3126 user_select_syms (candidates, n_candidates, 1);
3127 i = 0;
3128 }
3129
3130 exp->elts[pc + 1].block = candidates[i].block;
3131 exp->elts[pc + 2].symbol = candidates[i].sym;
1265e4aa
JB
3132 if (innermost_block == NULL
3133 || contained_in (candidates[i].block, innermost_block))
76a01679
JB
3134 innermost_block = candidates[i].block;
3135 }
3136
3137 if (deprocedure_p
3138 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3139 == TYPE_CODE_FUNC))
3140 {
3141 replace_operator_with_call (expp, pc, 0, 0,
3142 exp->elts[pc + 2].symbol,
3143 exp->elts[pc + 1].block);
3144 exp = *expp;
3145 }
14f9c5c9
AS
3146 break;
3147
3148 case OP_FUNCALL:
3149 {
4c4b4cd2 3150 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3151 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2
PH
3152 {
3153 struct ada_symbol_info *candidates;
3154 int n_candidates;
3155
3156 n_candidates =
76a01679
JB
3157 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3158 (exp->elts[pc + 5].symbol),
3159 exp->elts[pc + 4].block, VAR_DOMAIN,
d9680e73 3160 &candidates, 1);
4c4b4cd2
PH
3161 if (n_candidates == 1)
3162 i = 0;
3163 else
3164 {
06d5cf63
JB
3165 i = ada_resolve_function
3166 (candidates, n_candidates,
3167 argvec, nargs,
3168 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3169 context_type);
4c4b4cd2 3170 if (i < 0)
323e0a4a 3171 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3172 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3173 }
3174
3175 exp->elts[pc + 4].block = candidates[i].block;
3176 exp->elts[pc + 5].symbol = candidates[i].sym;
1265e4aa
JB
3177 if (innermost_block == NULL
3178 || contained_in (candidates[i].block, innermost_block))
4c4b4cd2
PH
3179 innermost_block = candidates[i].block;
3180 }
14f9c5c9
AS
3181 }
3182 break;
3183 case BINOP_ADD:
3184 case BINOP_SUB:
3185 case BINOP_MUL:
3186 case BINOP_DIV:
3187 case BINOP_REM:
3188 case BINOP_MOD:
3189 case BINOP_CONCAT:
3190 case BINOP_BITWISE_AND:
3191 case BINOP_BITWISE_IOR:
3192 case BINOP_BITWISE_XOR:
3193 case BINOP_EQUAL:
3194 case BINOP_NOTEQUAL:
3195 case BINOP_LESS:
3196 case BINOP_GTR:
3197 case BINOP_LEQ:
3198 case BINOP_GEQ:
3199 case BINOP_EXP:
3200 case UNOP_NEG:
3201 case UNOP_PLUS:
3202 case UNOP_LOGICAL_NOT:
3203 case UNOP_ABS:
3204 if (possible_user_operator_p (op, argvec))
4c4b4cd2
PH
3205 {
3206 struct ada_symbol_info *candidates;
3207 int n_candidates;
3208
3209 n_candidates =
3210 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3211 (struct block *) NULL, VAR_DOMAIN,
d9680e73 3212 &candidates, 1);
4c4b4cd2 3213 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
76a01679 3214 ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3215 if (i < 0)
3216 break;
3217
76a01679
JB
3218 replace_operator_with_call (expp, pc, nargs, 1,
3219 candidates[i].sym, candidates[i].block);
4c4b4cd2
PH
3220 exp = *expp;
3221 }
14f9c5c9 3222 break;
4c4b4cd2
PH
3223
3224 case OP_TYPE:
b3dbf008 3225 case OP_REGISTER:
4c4b4cd2 3226 return NULL;
14f9c5c9
AS
3227 }
3228
3229 *pos = pc;
3230 return evaluate_subexp_type (exp, pos);
3231}
3232
3233/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3234 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3235 a non-pointer. */
14f9c5c9 3236/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3237 liberal. */
14f9c5c9
AS
3238
3239static int
4dc81987 3240ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3241{
61ee279c
PH
3242 ftype = ada_check_typedef (ftype);
3243 atype = ada_check_typedef (atype);
14f9c5c9
AS
3244
3245 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3246 ftype = TYPE_TARGET_TYPE (ftype);
3247 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3248 atype = TYPE_TARGET_TYPE (atype);
3249
d2e4a39e 3250 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3251 {
3252 default:
5b3d5b7d 3253 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3254 case TYPE_CODE_PTR:
3255 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3256 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3257 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3258 else
1265e4aa
JB
3259 return (may_deref
3260 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3261 case TYPE_CODE_INT:
3262 case TYPE_CODE_ENUM:
3263 case TYPE_CODE_RANGE:
3264 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3265 {
3266 case TYPE_CODE_INT:
3267 case TYPE_CODE_ENUM:
3268 case TYPE_CODE_RANGE:
3269 return 1;
3270 default:
3271 return 0;
3272 }
14f9c5c9
AS
3273
3274 case TYPE_CODE_ARRAY:
d2e4a39e 3275 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3276 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3277
3278 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3279 if (ada_is_array_descriptor_type (ftype))
3280 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3281 || ada_is_array_descriptor_type (atype));
14f9c5c9 3282 else
4c4b4cd2
PH
3283 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3284 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3285
3286 case TYPE_CODE_UNION:
3287 case TYPE_CODE_FLT:
3288 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3289 }
3290}
3291
3292/* Return non-zero if the formals of FUNC "sufficiently match" the
3293 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3294 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3295 argument function. */
14f9c5c9
AS
3296
3297static int
d2e4a39e 3298ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3299{
3300 int i;
d2e4a39e 3301 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3302
1265e4aa
JB
3303 if (SYMBOL_CLASS (func) == LOC_CONST
3304 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3305 return (n_actuals == 0);
3306 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3307 return 0;
3308
3309 if (TYPE_NFIELDS (func_type) != n_actuals)
3310 return 0;
3311
3312 for (i = 0; i < n_actuals; i += 1)
3313 {
4c4b4cd2 3314 if (actuals[i] == NULL)
76a01679
JB
3315 return 0;
3316 else
3317 {
5b4ee69b
MS
3318 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3319 i));
df407dfe 3320 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3321
76a01679
JB
3322 if (!ada_type_match (ftype, atype, 1))
3323 return 0;
3324 }
14f9c5c9
AS
3325 }
3326 return 1;
3327}
3328
3329/* False iff function type FUNC_TYPE definitely does not produce a value
3330 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3331 FUNC_TYPE is not a valid function type with a non-null return type
3332 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3333
3334static int
d2e4a39e 3335return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3336{
d2e4a39e 3337 struct type *return_type;
14f9c5c9
AS
3338
3339 if (func_type == NULL)
3340 return 1;
3341
4c4b4cd2 3342 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3343 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3344 else
18af8284 3345 return_type = get_base_type (func_type);
14f9c5c9
AS
3346 if (return_type == NULL)
3347 return 1;
3348
18af8284 3349 context_type = get_base_type (context_type);
14f9c5c9
AS
3350
3351 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3352 return context_type == NULL || return_type == context_type;
3353 else if (context_type == NULL)
3354 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3355 else
3356 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3357}
3358
3359
4c4b4cd2 3360/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3361 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3362 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3363 that returns that type, then eliminate matches that don't. If
3364 CONTEXT_TYPE is void and there is at least one match that does not
3365 return void, eliminate all matches that do.
3366
14f9c5c9
AS
3367 Asks the user if there is more than one match remaining. Returns -1
3368 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3369 solely for messages. May re-arrange and modify SYMS in
3370 the process; the index returned is for the modified vector. */
14f9c5c9 3371
4c4b4cd2
PH
3372static int
3373ada_resolve_function (struct ada_symbol_info syms[],
3374 int nsyms, struct value **args, int nargs,
3375 const char *name, struct type *context_type)
14f9c5c9 3376{
30b15541 3377 int fallback;
14f9c5c9 3378 int k;
4c4b4cd2 3379 int m; /* Number of hits */
14f9c5c9 3380
d2e4a39e 3381 m = 0;
30b15541
UW
3382 /* In the first pass of the loop, we only accept functions matching
3383 context_type. If none are found, we add a second pass of the loop
3384 where every function is accepted. */
3385 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3386 {
3387 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3388 {
61ee279c 3389 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
4c4b4cd2
PH
3390
3391 if (ada_args_match (syms[k].sym, args, nargs)
30b15541 3392 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3393 {
3394 syms[m] = syms[k];
3395 m += 1;
3396 }
3397 }
14f9c5c9
AS
3398 }
3399
3400 if (m == 0)
3401 return -1;
3402 else if (m > 1)
3403 {
323e0a4a 3404 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3405 user_select_syms (syms, m, 1);
14f9c5c9
AS
3406 return 0;
3407 }
3408 return 0;
3409}
3410
4c4b4cd2
PH
3411/* Returns true (non-zero) iff decoded name N0 should appear before N1
3412 in a listing of choices during disambiguation (see sort_choices, below).
3413 The idea is that overloadings of a subprogram name from the
3414 same package should sort in their source order. We settle for ordering
3415 such symbols by their trailing number (__N or $N). */
3416
14f9c5c9 3417static int
0d5cff50 3418encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3419{
3420 if (N1 == NULL)
3421 return 0;
3422 else if (N0 == NULL)
3423 return 1;
3424 else
3425 {
3426 int k0, k1;
5b4ee69b 3427
d2e4a39e 3428 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3429 ;
d2e4a39e 3430 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3431 ;
d2e4a39e 3432 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3433 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3434 {
3435 int n0, n1;
5b4ee69b 3436
4c4b4cd2
PH
3437 n0 = k0;
3438 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3439 n0 -= 1;
3440 n1 = k1;
3441 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3442 n1 -= 1;
3443 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3444 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3445 }
14f9c5c9
AS
3446 return (strcmp (N0, N1) < 0);
3447 }
3448}
d2e4a39e 3449
4c4b4cd2
PH
3450/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3451 encoded names. */
3452
d2e4a39e 3453static void
4c4b4cd2 3454sort_choices (struct ada_symbol_info syms[], int nsyms)
14f9c5c9 3455{
4c4b4cd2 3456 int i;
5b4ee69b 3457
d2e4a39e 3458 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3459 {
4c4b4cd2 3460 struct ada_symbol_info sym = syms[i];
14f9c5c9
AS
3461 int j;
3462
d2e4a39e 3463 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2
PH
3464 {
3465 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3466 SYMBOL_LINKAGE_NAME (sym.sym)))
3467 break;
3468 syms[j + 1] = syms[j];
3469 }
d2e4a39e 3470 syms[j + 1] = sym;
14f9c5c9
AS
3471 }
3472}
3473
4c4b4cd2
PH
3474/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3475 by asking the user (if necessary), returning the number selected,
3476 and setting the first elements of SYMS items. Error if no symbols
3477 selected. */
14f9c5c9
AS
3478
3479/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3480 to be re-integrated one of these days. */
14f9c5c9
AS
3481
3482int
4c4b4cd2 3483user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
14f9c5c9
AS
3484{
3485 int i;
d2e4a39e 3486 int *chosen = (int *) alloca (sizeof (int) * nsyms);
14f9c5c9
AS
3487 int n_chosen;
3488 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3489 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3490
3491 if (max_results < 1)
323e0a4a 3492 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3493 if (nsyms <= 1)
3494 return nsyms;
3495
717d2f5a
JB
3496 if (select_mode == multiple_symbols_cancel)
3497 error (_("\
3498canceled because the command is ambiguous\n\
3499See set/show multiple-symbol."));
3500
3501 /* If select_mode is "all", then return all possible symbols.
3502 Only do that if more than one symbol can be selected, of course.
3503 Otherwise, display the menu as usual. */
3504 if (select_mode == multiple_symbols_all && max_results > 1)
3505 return nsyms;
3506
323e0a4a 3507 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3508 if (max_results > 1)
323e0a4a 3509 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3510
4c4b4cd2 3511 sort_choices (syms, nsyms);
14f9c5c9
AS
3512
3513 for (i = 0; i < nsyms; i += 1)
3514 {
4c4b4cd2
PH
3515 if (syms[i].sym == NULL)
3516 continue;
3517
3518 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3519 {
76a01679
JB
3520 struct symtab_and_line sal =
3521 find_function_start_sal (syms[i].sym, 1);
5b4ee69b 3522
323e0a4a
AC
3523 if (sal.symtab == NULL)
3524 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3525 i + first_choice,
3526 SYMBOL_PRINT_NAME (syms[i].sym),
3527 sal.line);
3528 else
3529 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3530 SYMBOL_PRINT_NAME (syms[i].sym),
3531 sal.symtab->filename, sal.line);
4c4b4cd2
PH
3532 continue;
3533 }
d2e4a39e 3534 else
4c4b4cd2
PH
3535 {
3536 int is_enumeral =
3537 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3538 && SYMBOL_TYPE (syms[i].sym) != NULL
3539 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
6f38eac8 3540 struct symtab *symtab = syms[i].sym->symtab;
4c4b4cd2
PH
3541
3542 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
323e0a4a 3543 printf_unfiltered (_("[%d] %s at %s:%d\n"),
4c4b4cd2
PH
3544 i + first_choice,
3545 SYMBOL_PRINT_NAME (syms[i].sym),
3546 symtab->filename, SYMBOL_LINE (syms[i].sym));
76a01679
JB
3547 else if (is_enumeral
3548 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
4c4b4cd2 3549 {
a3f17187 3550 printf_unfiltered (("[%d] "), i + first_choice);
76a01679
JB
3551 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
3552 gdb_stdout, -1, 0);
323e0a4a 3553 printf_unfiltered (_("'(%s) (enumeral)\n"),
4c4b4cd2
PH
3554 SYMBOL_PRINT_NAME (syms[i].sym));
3555 }
3556 else if (symtab != NULL)
3557 printf_unfiltered (is_enumeral
323e0a4a
AC
3558 ? _("[%d] %s in %s (enumeral)\n")
3559 : _("[%d] %s at %s:?\n"),
4c4b4cd2
PH
3560 i + first_choice,
3561 SYMBOL_PRINT_NAME (syms[i].sym),
3562 symtab->filename);
3563 else
3564 printf_unfiltered (is_enumeral
323e0a4a
AC
3565 ? _("[%d] %s (enumeral)\n")
3566 : _("[%d] %s at ?\n"),
4c4b4cd2
PH
3567 i + first_choice,
3568 SYMBOL_PRINT_NAME (syms[i].sym));
3569 }
14f9c5c9 3570 }
d2e4a39e 3571
14f9c5c9 3572 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 3573 "overload-choice");
14f9c5c9
AS
3574
3575 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 3576 syms[i] = syms[chosen[i]];
14f9c5c9
AS
3577
3578 return n_chosen;
3579}
3580
3581/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 3582 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
3583 order in CHOICES[0 .. N-1], and return N.
3584
3585 The user types choices as a sequence of numbers on one line
3586 separated by blanks, encoding them as follows:
3587
4c4b4cd2 3588 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
3589 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3590 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3591
4c4b4cd2 3592 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
3593
3594 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 3595 prompts (for use with the -f switch). */
14f9c5c9
AS
3596
3597int
d2e4a39e 3598get_selections (int *choices, int n_choices, int max_results,
4c4b4cd2 3599 int is_all_choice, char *annotation_suffix)
14f9c5c9 3600{
d2e4a39e 3601 char *args;
0bcd0149 3602 char *prompt;
14f9c5c9
AS
3603 int n_chosen;
3604 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 3605
14f9c5c9
AS
3606 prompt = getenv ("PS2");
3607 if (prompt == NULL)
0bcd0149 3608 prompt = "> ";
14f9c5c9 3609
0bcd0149 3610 args = command_line_input (prompt, 0, annotation_suffix);
d2e4a39e 3611
14f9c5c9 3612 if (args == NULL)
323e0a4a 3613 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
3614
3615 n_chosen = 0;
76a01679 3616
4c4b4cd2
PH
3617 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3618 order, as given in args. Choices are validated. */
14f9c5c9
AS
3619 while (1)
3620 {
d2e4a39e 3621 char *args2;
14f9c5c9
AS
3622 int choice, j;
3623
0fcd72ba 3624 args = skip_spaces (args);
14f9c5c9 3625 if (*args == '\0' && n_chosen == 0)
323e0a4a 3626 error_no_arg (_("one or more choice numbers"));
14f9c5c9 3627 else if (*args == '\0')
4c4b4cd2 3628 break;
14f9c5c9
AS
3629
3630 choice = strtol (args, &args2, 10);
d2e4a39e 3631 if (args == args2 || choice < 0
4c4b4cd2 3632 || choice > n_choices + first_choice - 1)
323e0a4a 3633 error (_("Argument must be choice number"));
14f9c5c9
AS
3634 args = args2;
3635
d2e4a39e 3636 if (choice == 0)
323e0a4a 3637 error (_("cancelled"));
14f9c5c9
AS
3638
3639 if (choice < first_choice)
4c4b4cd2
PH
3640 {
3641 n_chosen = n_choices;
3642 for (j = 0; j < n_choices; j += 1)
3643 choices[j] = j;
3644 break;
3645 }
14f9c5c9
AS
3646 choice -= first_choice;
3647
d2e4a39e 3648 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
3649 {
3650 }
14f9c5c9
AS
3651
3652 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
3653 {
3654 int k;
5b4ee69b 3655
4c4b4cd2
PH
3656 for (k = n_chosen - 1; k > j; k -= 1)
3657 choices[k + 1] = choices[k];
3658 choices[j + 1] = choice;
3659 n_chosen += 1;
3660 }
14f9c5c9
AS
3661 }
3662
3663 if (n_chosen > max_results)
323e0a4a 3664 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 3665
14f9c5c9
AS
3666 return n_chosen;
3667}
3668
4c4b4cd2
PH
3669/* Replace the operator of length OPLEN at position PC in *EXPP with a call
3670 on the function identified by SYM and BLOCK, and taking NARGS
3671 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
3672
3673static void
d2e4a39e 3674replace_operator_with_call (struct expression **expp, int pc, int nargs,
4c4b4cd2
PH
3675 int oplen, struct symbol *sym,
3676 struct block *block)
14f9c5c9
AS
3677{
3678 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 3679 symbol, -oplen for operator being replaced). */
d2e4a39e 3680 struct expression *newexp = (struct expression *)
8c1a34e7 3681 xzalloc (sizeof (struct expression)
4c4b4cd2 3682 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
d2e4a39e 3683 struct expression *exp = *expp;
14f9c5c9
AS
3684
3685 newexp->nelts = exp->nelts + 7 - oplen;
3686 newexp->language_defn = exp->language_defn;
3489610d 3687 newexp->gdbarch = exp->gdbarch;
14f9c5c9 3688 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 3689 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 3690 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
3691
3692 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3693 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3694
3695 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3696 newexp->elts[pc + 4].block = block;
3697 newexp->elts[pc + 5].symbol = sym;
3698
3699 *expp = newexp;
aacb1f0a 3700 xfree (exp);
d2e4a39e 3701}
14f9c5c9
AS
3702
3703/* Type-class predicates */
3704
4c4b4cd2
PH
3705/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3706 or FLOAT). */
14f9c5c9
AS
3707
3708static int
d2e4a39e 3709numeric_type_p (struct type *type)
14f9c5c9
AS
3710{
3711 if (type == NULL)
3712 return 0;
d2e4a39e
AS
3713 else
3714 {
3715 switch (TYPE_CODE (type))
4c4b4cd2
PH
3716 {
3717 case TYPE_CODE_INT:
3718 case TYPE_CODE_FLT:
3719 return 1;
3720 case TYPE_CODE_RANGE:
3721 return (type == TYPE_TARGET_TYPE (type)
3722 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3723 default:
3724 return 0;
3725 }
d2e4a39e 3726 }
14f9c5c9
AS
3727}
3728
4c4b4cd2 3729/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
3730
3731static int
d2e4a39e 3732integer_type_p (struct type *type)
14f9c5c9
AS
3733{
3734 if (type == NULL)
3735 return 0;
d2e4a39e
AS
3736 else
3737 {
3738 switch (TYPE_CODE (type))
4c4b4cd2
PH
3739 {
3740 case TYPE_CODE_INT:
3741 return 1;
3742 case TYPE_CODE_RANGE:
3743 return (type == TYPE_TARGET_TYPE (type)
3744 || integer_type_p (TYPE_TARGET_TYPE (type)));
3745 default:
3746 return 0;
3747 }
d2e4a39e 3748 }
14f9c5c9
AS
3749}
3750
4c4b4cd2 3751/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
3752
3753static int
d2e4a39e 3754scalar_type_p (struct type *type)
14f9c5c9
AS
3755{
3756 if (type == NULL)
3757 return 0;
d2e4a39e
AS
3758 else
3759 {
3760 switch (TYPE_CODE (type))
4c4b4cd2
PH
3761 {
3762 case TYPE_CODE_INT:
3763 case TYPE_CODE_RANGE:
3764 case TYPE_CODE_ENUM:
3765 case TYPE_CODE_FLT:
3766 return 1;
3767 default:
3768 return 0;
3769 }
d2e4a39e 3770 }
14f9c5c9
AS
3771}
3772
4c4b4cd2 3773/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
3774
3775static int
d2e4a39e 3776discrete_type_p (struct type *type)
14f9c5c9
AS
3777{
3778 if (type == NULL)
3779 return 0;
d2e4a39e
AS
3780 else
3781 {
3782 switch (TYPE_CODE (type))
4c4b4cd2
PH
3783 {
3784 case TYPE_CODE_INT:
3785 case TYPE_CODE_RANGE:
3786 case TYPE_CODE_ENUM:
872f0337 3787 case TYPE_CODE_BOOL:
4c4b4cd2
PH
3788 return 1;
3789 default:
3790 return 0;
3791 }
d2e4a39e 3792 }
14f9c5c9
AS
3793}
3794
4c4b4cd2
PH
3795/* Returns non-zero if OP with operands in the vector ARGS could be
3796 a user-defined function. Errs on the side of pre-defined operators
3797 (i.e., result 0). */
14f9c5c9
AS
3798
3799static int
d2e4a39e 3800possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 3801{
76a01679 3802 struct type *type0 =
df407dfe 3803 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 3804 struct type *type1 =
df407dfe 3805 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 3806
4c4b4cd2
PH
3807 if (type0 == NULL)
3808 return 0;
3809
14f9c5c9
AS
3810 switch (op)
3811 {
3812 default:
3813 return 0;
3814
3815 case BINOP_ADD:
3816 case BINOP_SUB:
3817 case BINOP_MUL:
3818 case BINOP_DIV:
d2e4a39e 3819 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
3820
3821 case BINOP_REM:
3822 case BINOP_MOD:
3823 case BINOP_BITWISE_AND:
3824 case BINOP_BITWISE_IOR:
3825 case BINOP_BITWISE_XOR:
d2e4a39e 3826 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3827
3828 case BINOP_EQUAL:
3829 case BINOP_NOTEQUAL:
3830 case BINOP_LESS:
3831 case BINOP_GTR:
3832 case BINOP_LEQ:
3833 case BINOP_GEQ:
d2e4a39e 3834 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
3835
3836 case BINOP_CONCAT:
ee90b9ab 3837 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
3838
3839 case BINOP_EXP:
d2e4a39e 3840 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3841
3842 case UNOP_NEG:
3843 case UNOP_PLUS:
3844 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
3845 case UNOP_ABS:
3846 return (!numeric_type_p (type0));
14f9c5c9
AS
3847
3848 }
3849}
3850\f
4c4b4cd2 3851 /* Renaming */
14f9c5c9 3852
aeb5907d
JB
3853/* NOTES:
3854
3855 1. In the following, we assume that a renaming type's name may
3856 have an ___XD suffix. It would be nice if this went away at some
3857 point.
3858 2. We handle both the (old) purely type-based representation of
3859 renamings and the (new) variable-based encoding. At some point,
3860 it is devoutly to be hoped that the former goes away
3861 (FIXME: hilfinger-2007-07-09).
3862 3. Subprogram renamings are not implemented, although the XRS
3863 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3864
3865/* If SYM encodes a renaming,
3866
3867 <renaming> renames <renamed entity>,
3868
3869 sets *LEN to the length of the renamed entity's name,
3870 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3871 the string describing the subcomponent selected from the renamed
0963b4bd 3872 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
3873 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3874 are undefined). Otherwise, returns a value indicating the category
3875 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3876 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3877 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3878 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3879 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3880 may be NULL, in which case they are not assigned.
3881
3882 [Currently, however, GCC does not generate subprogram renamings.] */
3883
3884enum ada_renaming_category
3885ada_parse_renaming (struct symbol *sym,
3886 const char **renamed_entity, int *len,
3887 const char **renaming_expr)
3888{
3889 enum ada_renaming_category kind;
3890 const char *info;
3891 const char *suffix;
3892
3893 if (sym == NULL)
3894 return ADA_NOT_RENAMING;
3895 switch (SYMBOL_CLASS (sym))
14f9c5c9 3896 {
aeb5907d
JB
3897 default:
3898 return ADA_NOT_RENAMING;
3899 case LOC_TYPEDEF:
3900 return parse_old_style_renaming (SYMBOL_TYPE (sym),
3901 renamed_entity, len, renaming_expr);
3902 case LOC_LOCAL:
3903 case LOC_STATIC:
3904 case LOC_COMPUTED:
3905 case LOC_OPTIMIZED_OUT:
3906 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
3907 if (info == NULL)
3908 return ADA_NOT_RENAMING;
3909 switch (info[5])
3910 {
3911 case '_':
3912 kind = ADA_OBJECT_RENAMING;
3913 info += 6;
3914 break;
3915 case 'E':
3916 kind = ADA_EXCEPTION_RENAMING;
3917 info += 7;
3918 break;
3919 case 'P':
3920 kind = ADA_PACKAGE_RENAMING;
3921 info += 7;
3922 break;
3923 case 'S':
3924 kind = ADA_SUBPROGRAM_RENAMING;
3925 info += 7;
3926 break;
3927 default:
3928 return ADA_NOT_RENAMING;
3929 }
14f9c5c9 3930 }
4c4b4cd2 3931
aeb5907d
JB
3932 if (renamed_entity != NULL)
3933 *renamed_entity = info;
3934 suffix = strstr (info, "___XE");
3935 if (suffix == NULL || suffix == info)
3936 return ADA_NOT_RENAMING;
3937 if (len != NULL)
3938 *len = strlen (info) - strlen (suffix);
3939 suffix += 5;
3940 if (renaming_expr != NULL)
3941 *renaming_expr = suffix;
3942 return kind;
3943}
3944
3945/* Assuming TYPE encodes a renaming according to the old encoding in
3946 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3947 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3948 ADA_NOT_RENAMING otherwise. */
3949static enum ada_renaming_category
3950parse_old_style_renaming (struct type *type,
3951 const char **renamed_entity, int *len,
3952 const char **renaming_expr)
3953{
3954 enum ada_renaming_category kind;
3955 const char *name;
3956 const char *info;
3957 const char *suffix;
14f9c5c9 3958
aeb5907d
JB
3959 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
3960 || TYPE_NFIELDS (type) != 1)
3961 return ADA_NOT_RENAMING;
14f9c5c9 3962
aeb5907d
JB
3963 name = type_name_no_tag (type);
3964 if (name == NULL)
3965 return ADA_NOT_RENAMING;
3966
3967 name = strstr (name, "___XR");
3968 if (name == NULL)
3969 return ADA_NOT_RENAMING;
3970 switch (name[5])
3971 {
3972 case '\0':
3973 case '_':
3974 kind = ADA_OBJECT_RENAMING;
3975 break;
3976 case 'E':
3977 kind = ADA_EXCEPTION_RENAMING;
3978 break;
3979 case 'P':
3980 kind = ADA_PACKAGE_RENAMING;
3981 break;
3982 case 'S':
3983 kind = ADA_SUBPROGRAM_RENAMING;
3984 break;
3985 default:
3986 return ADA_NOT_RENAMING;
3987 }
14f9c5c9 3988
aeb5907d
JB
3989 info = TYPE_FIELD_NAME (type, 0);
3990 if (info == NULL)
3991 return ADA_NOT_RENAMING;
3992 if (renamed_entity != NULL)
3993 *renamed_entity = info;
3994 suffix = strstr (info, "___XE");
3995 if (renaming_expr != NULL)
3996 *renaming_expr = suffix + 5;
3997 if (suffix == NULL || suffix == info)
3998 return ADA_NOT_RENAMING;
3999 if (len != NULL)
4000 *len = suffix - info;
4001 return kind;
4002}
52ce6436 4003
14f9c5c9 4004\f
d2e4a39e 4005
4c4b4cd2 4006 /* Evaluation: Function Calls */
14f9c5c9 4007
4c4b4cd2 4008/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4009 lvalues, and otherwise has the side-effect of allocating memory
4010 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4011
d2e4a39e 4012static struct value *
40bc484c 4013ensure_lval (struct value *val)
14f9c5c9 4014{
40bc484c
JB
4015 if (VALUE_LVAL (val) == not_lval
4016 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4017 {
df407dfe 4018 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4019 const CORE_ADDR addr =
4020 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4021
40bc484c 4022 set_value_address (val, addr);
a84a8a0d 4023 VALUE_LVAL (val) = lval_memory;
40bc484c 4024 write_memory (addr, value_contents (val), len);
c3e5cd34 4025 }
14f9c5c9
AS
4026
4027 return val;
4028}
4029
4030/* Return the value ACTUAL, converted to be an appropriate value for a
4031 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4032 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4033 values not residing in memory, updating it as needed. */
14f9c5c9 4034
a93c0eb6 4035struct value *
40bc484c 4036ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4037{
df407dfe 4038 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4039 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4040 struct type *formal_target =
4041 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4042 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4043 struct type *actual_target =
4044 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4045 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4046
4c4b4cd2 4047 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4048 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4049 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4050 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4051 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4052 {
a84a8a0d 4053 struct value *result;
5b4ee69b 4054
14f9c5c9 4055 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4056 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4057 result = desc_data (actual);
14f9c5c9 4058 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4059 {
4060 if (VALUE_LVAL (actual) != lval_memory)
4061 {
4062 struct value *val;
5b4ee69b 4063
df407dfe 4064 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4065 val = allocate_value (actual_type);
990a07ab 4066 memcpy ((char *) value_contents_raw (val),
0fd88904 4067 (char *) value_contents (actual),
4c4b4cd2 4068 TYPE_LENGTH (actual_type));
40bc484c 4069 actual = ensure_lval (val);
4c4b4cd2 4070 }
a84a8a0d 4071 result = value_addr (actual);
4c4b4cd2 4072 }
a84a8a0d
JB
4073 else
4074 return actual;
4075 return value_cast_pointers (formal_type, result);
14f9c5c9
AS
4076 }
4077 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4078 return ada_value_ind (actual);
4079
4080 return actual;
4081}
4082
438c98a1
JB
4083/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4084 type TYPE. This is usually an inefficient no-op except on some targets
4085 (such as AVR) where the representation of a pointer and an address
4086 differs. */
4087
4088static CORE_ADDR
4089value_pointer (struct value *value, struct type *type)
4090{
4091 struct gdbarch *gdbarch = get_type_arch (type);
4092 unsigned len = TYPE_LENGTH (type);
4093 gdb_byte *buf = alloca (len);
4094 CORE_ADDR addr;
4095
4096 addr = value_address (value);
4097 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4098 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4099 return addr;
4100}
4101
14f9c5c9 4102
4c4b4cd2
PH
4103/* Push a descriptor of type TYPE for array value ARR on the stack at
4104 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4105 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4106 to-descriptor type rather than a descriptor type), a struct value *
4107 representing a pointer to this descriptor. */
14f9c5c9 4108
d2e4a39e 4109static struct value *
40bc484c 4110make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4111{
d2e4a39e
AS
4112 struct type *bounds_type = desc_bounds_type (type);
4113 struct type *desc_type = desc_base_type (type);
4114 struct value *descriptor = allocate_value (desc_type);
4115 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4116 int i;
d2e4a39e 4117
0963b4bd
MS
4118 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4119 i > 0; i -= 1)
14f9c5c9 4120 {
19f220c3
JK
4121 modify_field (value_type (bounds), value_contents_writeable (bounds),
4122 ada_array_bound (arr, i, 0),
4123 desc_bound_bitpos (bounds_type, i, 0),
4124 desc_bound_bitsize (bounds_type, i, 0));
4125 modify_field (value_type (bounds), value_contents_writeable (bounds),
4126 ada_array_bound (arr, i, 1),
4127 desc_bound_bitpos (bounds_type, i, 1),
4128 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4129 }
d2e4a39e 4130
40bc484c 4131 bounds = ensure_lval (bounds);
d2e4a39e 4132
19f220c3
JK
4133 modify_field (value_type (descriptor),
4134 value_contents_writeable (descriptor),
4135 value_pointer (ensure_lval (arr),
4136 TYPE_FIELD_TYPE (desc_type, 0)),
4137 fat_pntr_data_bitpos (desc_type),
4138 fat_pntr_data_bitsize (desc_type));
4139
4140 modify_field (value_type (descriptor),
4141 value_contents_writeable (descriptor),
4142 value_pointer (bounds,
4143 TYPE_FIELD_TYPE (desc_type, 1)),
4144 fat_pntr_bounds_bitpos (desc_type),
4145 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4146
40bc484c 4147 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4148
4149 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4150 return value_addr (descriptor);
4151 else
4152 return descriptor;
4153}
14f9c5c9 4154\f
963a6417 4155/* Dummy definitions for an experimental caching module that is not
0963b4bd 4156 * used in the public sources. */
96d887e8 4157
96d887e8
PH
4158static int
4159lookup_cached_symbol (const char *name, domain_enum namespace,
2570f2b7 4160 struct symbol **sym, struct block **block)
96d887e8
PH
4161{
4162 return 0;
4163}
4164
4165static void
4166cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
2570f2b7 4167 struct block *block)
96d887e8
PH
4168{
4169}
4c4b4cd2
PH
4170\f
4171 /* Symbol Lookup */
4172
c0431670
JB
4173/* Return nonzero if wild matching should be used when searching for
4174 all symbols matching LOOKUP_NAME.
4175
4176 LOOKUP_NAME is expected to be a symbol name after transformation
4177 for Ada lookups (see ada_name_for_lookup). */
4178
4179static int
4180should_use_wild_match (const char *lookup_name)
4181{
4182 return (strstr (lookup_name, "__") == NULL);
4183}
4184
4c4b4cd2
PH
4185/* Return the result of a standard (literal, C-like) lookup of NAME in
4186 given DOMAIN, visible from lexical block BLOCK. */
4187
4188static struct symbol *
4189standard_lookup (const char *name, const struct block *block,
4190 domain_enum domain)
4191{
4192 struct symbol *sym;
4c4b4cd2 4193
2570f2b7 4194 if (lookup_cached_symbol (name, domain, &sym, NULL))
4c4b4cd2 4195 return sym;
2570f2b7
UW
4196 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4197 cache_symbol (name, domain, sym, block_found);
4c4b4cd2
PH
4198 return sym;
4199}
4200
4201
4202/* Non-zero iff there is at least one non-function/non-enumeral symbol
4203 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4204 since they contend in overloading in the same way. */
4205static int
4206is_nonfunction (struct ada_symbol_info syms[], int n)
4207{
4208 int i;
4209
4210 for (i = 0; i < n; i += 1)
4211 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
4212 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
4213 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
14f9c5c9
AS
4214 return 1;
4215
4216 return 0;
4217}
4218
4219/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4220 struct types. Otherwise, they may not. */
14f9c5c9
AS
4221
4222static int
d2e4a39e 4223equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4224{
d2e4a39e 4225 if (type0 == type1)
14f9c5c9 4226 return 1;
d2e4a39e 4227 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4228 || TYPE_CODE (type0) != TYPE_CODE (type1))
4229 return 0;
d2e4a39e 4230 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4231 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4232 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4233 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4234 return 1;
d2e4a39e 4235
14f9c5c9
AS
4236 return 0;
4237}
4238
4239/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4240 no more defined than that of SYM1. */
14f9c5c9
AS
4241
4242static int
d2e4a39e 4243lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4244{
4245 if (sym0 == sym1)
4246 return 1;
176620f1 4247 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4248 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4249 return 0;
4250
d2e4a39e 4251 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4252 {
4253 case LOC_UNDEF:
4254 return 1;
4255 case LOC_TYPEDEF:
4256 {
4c4b4cd2
PH
4257 struct type *type0 = SYMBOL_TYPE (sym0);
4258 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4259 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4260 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4261 int len0 = strlen (name0);
5b4ee69b 4262
4c4b4cd2
PH
4263 return
4264 TYPE_CODE (type0) == TYPE_CODE (type1)
4265 && (equiv_types (type0, type1)
4266 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4267 && strncmp (name1 + len0, "___XV", 5) == 0));
14f9c5c9
AS
4268 }
4269 case LOC_CONST:
4270 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4271 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4272 default:
4273 return 0;
14f9c5c9
AS
4274 }
4275}
4276
4c4b4cd2
PH
4277/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4278 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4279
4280static void
76a01679
JB
4281add_defn_to_vec (struct obstack *obstackp,
4282 struct symbol *sym,
2570f2b7 4283 struct block *block)
14f9c5c9
AS
4284{
4285 int i;
4c4b4cd2 4286 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4287
529cad9c
PH
4288 /* Do not try to complete stub types, as the debugger is probably
4289 already scanning all symbols matching a certain name at the
4290 time when this function is called. Trying to replace the stub
4291 type by its associated full type will cause us to restart a scan
4292 which may lead to an infinite recursion. Instead, the client
4293 collecting the matching symbols will end up collecting several
4294 matches, with at least one of them complete. It can then filter
4295 out the stub ones if needed. */
4296
4c4b4cd2
PH
4297 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4298 {
4299 if (lesseq_defined_than (sym, prevDefns[i].sym))
4300 return;
4301 else if (lesseq_defined_than (prevDefns[i].sym, sym))
4302 {
4303 prevDefns[i].sym = sym;
4304 prevDefns[i].block = block;
4c4b4cd2 4305 return;
76a01679 4306 }
4c4b4cd2
PH
4307 }
4308
4309 {
4310 struct ada_symbol_info info;
4311
4312 info.sym = sym;
4313 info.block = block;
4c4b4cd2
PH
4314 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
4315 }
4316}
4317
4318/* Number of ada_symbol_info structures currently collected in
4319 current vector in *OBSTACKP. */
4320
76a01679
JB
4321static int
4322num_defns_collected (struct obstack *obstackp)
4c4b4cd2
PH
4323{
4324 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
4325}
4326
4327/* Vector of ada_symbol_info structures currently collected in current
4328 vector in *OBSTACKP. If FINISH, close off the vector and return
4329 its final address. */
4330
76a01679 4331static struct ada_symbol_info *
4c4b4cd2
PH
4332defns_collected (struct obstack *obstackp, int finish)
4333{
4334 if (finish)
4335 return obstack_finish (obstackp);
4336 else
4337 return (struct ada_symbol_info *) obstack_base (obstackp);
4338}
4339
96d887e8
PH
4340/* Return a minimal symbol matching NAME according to Ada decoding
4341 rules. Returns NULL if there is no such minimal symbol. Names
4342 prefixed with "standard__" are handled specially: "standard__" is
4343 first stripped off, and only static and global symbols are searched. */
4c4b4cd2 4344
96d887e8
PH
4345struct minimal_symbol *
4346ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4347{
4c4b4cd2 4348 struct objfile *objfile;
96d887e8 4349 struct minimal_symbol *msymbol;
c0431670 4350 const int wild_match = should_use_wild_match (name);
4c4b4cd2 4351
c0431670
JB
4352 /* Special case: If the user specifies a symbol name inside package
4353 Standard, do a non-wild matching of the symbol name without
4354 the "standard__" prefix. This was primarily introduced in order
4355 to allow the user to specifically access the standard exceptions
4356 using, for instance, Standard.Constraint_Error when Constraint_Error
4357 is ambiguous (due to the user defining its own Constraint_Error
4358 entity inside its program). */
96d887e8 4359 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
c0431670 4360 name += sizeof ("standard__") - 1;
4c4b4cd2 4361
96d887e8
PH
4362 ALL_MSYMBOLS (objfile, msymbol)
4363 {
40658b94 4364 if (match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match)
96d887e8
PH
4365 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4366 return msymbol;
4367 }
4c4b4cd2 4368
96d887e8
PH
4369 return NULL;
4370}
4c4b4cd2 4371
96d887e8
PH
4372/* For all subprograms that statically enclose the subprogram of the
4373 selected frame, add symbols matching identifier NAME in DOMAIN
4374 and their blocks to the list of data in OBSTACKP, as for
4375 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4376 wildcard prefix. */
4c4b4cd2 4377
96d887e8
PH
4378static void
4379add_symbols_from_enclosing_procs (struct obstack *obstackp,
76a01679 4380 const char *name, domain_enum namespace,
96d887e8
PH
4381 int wild_match)
4382{
96d887e8 4383}
14f9c5c9 4384
96d887e8
PH
4385/* True if TYPE is definitely an artificial type supplied to a symbol
4386 for which no debugging information was given in the symbol file. */
14f9c5c9 4387
96d887e8
PH
4388static int
4389is_nondebugging_type (struct type *type)
4390{
0d5cff50 4391 const char *name = ada_type_name (type);
5b4ee69b 4392
96d887e8
PH
4393 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4394}
4c4b4cd2 4395
8f17729f
JB
4396/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4397 that are deemed "identical" for practical purposes.
4398
4399 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4400 types and that their number of enumerals is identical (in other
4401 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4402
4403static int
4404ada_identical_enum_types_p (struct type *type1, struct type *type2)
4405{
4406 int i;
4407
4408 /* The heuristic we use here is fairly conservative. We consider
4409 that 2 enumerate types are identical if they have the same
4410 number of enumerals and that all enumerals have the same
4411 underlying value and name. */
4412
4413 /* All enums in the type should have an identical underlying value. */
4414 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4415 if (TYPE_FIELD_BITPOS (type1, i) != TYPE_FIELD_BITPOS (type2, i))
4416 return 0;
4417
4418 /* All enumerals should also have the same name (modulo any numerical
4419 suffix). */
4420 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4421 {
0d5cff50
DE
4422 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4423 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
4424 int len_1 = strlen (name_1);
4425 int len_2 = strlen (name_2);
4426
4427 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4428 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4429 if (len_1 != len_2
4430 || strncmp (TYPE_FIELD_NAME (type1, i),
4431 TYPE_FIELD_NAME (type2, i),
4432 len_1) != 0)
4433 return 0;
4434 }
4435
4436 return 1;
4437}
4438
4439/* Return nonzero if all the symbols in SYMS are all enumeral symbols
4440 that are deemed "identical" for practical purposes. Sometimes,
4441 enumerals are not strictly identical, but their types are so similar
4442 that they can be considered identical.
4443
4444 For instance, consider the following code:
4445
4446 type Color is (Black, Red, Green, Blue, White);
4447 type RGB_Color is new Color range Red .. Blue;
4448
4449 Type RGB_Color is a subrange of an implicit type which is a copy
4450 of type Color. If we call that implicit type RGB_ColorB ("B" is
4451 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4452 As a result, when an expression references any of the enumeral
4453 by name (Eg. "print green"), the expression is technically
4454 ambiguous and the user should be asked to disambiguate. But
4455 doing so would only hinder the user, since it wouldn't matter
4456 what choice he makes, the outcome would always be the same.
4457 So, for practical purposes, we consider them as the same. */
4458
4459static int
4460symbols_are_identical_enums (struct ada_symbol_info *syms, int nsyms)
4461{
4462 int i;
4463
4464 /* Before performing a thorough comparison check of each type,
4465 we perform a series of inexpensive checks. We expect that these
4466 checks will quickly fail in the vast majority of cases, and thus
4467 help prevent the unnecessary use of a more expensive comparison.
4468 Said comparison also expects us to make some of these checks
4469 (see ada_identical_enum_types_p). */
4470
4471 /* Quick check: All symbols should have an enum type. */
4472 for (i = 0; i < nsyms; i++)
4473 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM)
4474 return 0;
4475
4476 /* Quick check: They should all have the same value. */
4477 for (i = 1; i < nsyms; i++)
4478 if (SYMBOL_VALUE (syms[i].sym) != SYMBOL_VALUE (syms[0].sym))
4479 return 0;
4480
4481 /* Quick check: They should all have the same number of enumerals. */
4482 for (i = 1; i < nsyms; i++)
4483 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].sym))
4484 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].sym)))
4485 return 0;
4486
4487 /* All the sanity checks passed, so we might have a set of
4488 identical enumeration types. Perform a more complete
4489 comparison of the type of each symbol. */
4490 for (i = 1; i < nsyms; i++)
4491 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].sym),
4492 SYMBOL_TYPE (syms[0].sym)))
4493 return 0;
4494
4495 return 1;
4496}
4497
96d887e8
PH
4498/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4499 duplicate other symbols in the list (The only case I know of where
4500 this happens is when object files containing stabs-in-ecoff are
4501 linked with files containing ordinary ecoff debugging symbols (or no
4502 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4503 Returns the number of items in the modified list. */
4c4b4cd2 4504
96d887e8
PH
4505static int
4506remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4507{
4508 int i, j;
4c4b4cd2 4509
8f17729f
JB
4510 /* We should never be called with less than 2 symbols, as there
4511 cannot be any extra symbol in that case. But it's easy to
4512 handle, since we have nothing to do in that case. */
4513 if (nsyms < 2)
4514 return nsyms;
4515
96d887e8
PH
4516 i = 0;
4517 while (i < nsyms)
4518 {
a35ddb44 4519 int remove_p = 0;
339c13b6
JB
4520
4521 /* If two symbols have the same name and one of them is a stub type,
4522 the get rid of the stub. */
4523
4524 if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym))
4525 && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL)
4526 {
4527 for (j = 0; j < nsyms; j++)
4528 {
4529 if (j != i
4530 && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym))
4531 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4532 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4533 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0)
a35ddb44 4534 remove_p = 1;
339c13b6
JB
4535 }
4536 }
4537
4538 /* Two symbols with the same name, same class and same address
4539 should be identical. */
4540
4541 else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
96d887e8
PH
4542 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4543 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4544 {
4545 for (j = 0; j < nsyms; j += 1)
4546 {
4547 if (i != j
4548 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4549 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
76a01679 4550 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
96d887e8
PH
4551 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4552 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4553 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
a35ddb44 4554 remove_p = 1;
4c4b4cd2 4555 }
4c4b4cd2 4556 }
339c13b6 4557
a35ddb44 4558 if (remove_p)
339c13b6
JB
4559 {
4560 for (j = i + 1; j < nsyms; j += 1)
4561 syms[j - 1] = syms[j];
4562 nsyms -= 1;
4563 }
4564
96d887e8 4565 i += 1;
14f9c5c9 4566 }
8f17729f
JB
4567
4568 /* If all the remaining symbols are identical enumerals, then
4569 just keep the first one and discard the rest.
4570
4571 Unlike what we did previously, we do not discard any entry
4572 unless they are ALL identical. This is because the symbol
4573 comparison is not a strict comparison, but rather a practical
4574 comparison. If all symbols are considered identical, then
4575 we can just go ahead and use the first one and discard the rest.
4576 But if we cannot reduce the list to a single element, we have
4577 to ask the user to disambiguate anyways. And if we have to
4578 present a multiple-choice menu, it's less confusing if the list
4579 isn't missing some choices that were identical and yet distinct. */
4580 if (symbols_are_identical_enums (syms, nsyms))
4581 nsyms = 1;
4582
96d887e8 4583 return nsyms;
14f9c5c9
AS
4584}
4585
96d887e8
PH
4586/* Given a type that corresponds to a renaming entity, use the type name
4587 to extract the scope (package name or function name, fully qualified,
4588 and following the GNAT encoding convention) where this renaming has been
4589 defined. The string returned needs to be deallocated after use. */
4c4b4cd2 4590
96d887e8
PH
4591static char *
4592xget_renaming_scope (struct type *renaming_type)
14f9c5c9 4593{
96d887e8 4594 /* The renaming types adhere to the following convention:
0963b4bd 4595 <scope>__<rename>___<XR extension>.
96d887e8
PH
4596 So, to extract the scope, we search for the "___XR" extension,
4597 and then backtrack until we find the first "__". */
76a01679 4598
96d887e8
PH
4599 const char *name = type_name_no_tag (renaming_type);
4600 char *suffix = strstr (name, "___XR");
4601 char *last;
4602 int scope_len;
4603 char *scope;
14f9c5c9 4604
96d887e8
PH
4605 /* Now, backtrack a bit until we find the first "__". Start looking
4606 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 4607
96d887e8
PH
4608 for (last = suffix - 3; last > name; last--)
4609 if (last[0] == '_' && last[1] == '_')
4610 break;
76a01679 4611
96d887e8 4612 /* Make a copy of scope and return it. */
14f9c5c9 4613
96d887e8
PH
4614 scope_len = last - name;
4615 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
14f9c5c9 4616
96d887e8
PH
4617 strncpy (scope, name, scope_len);
4618 scope[scope_len] = '\0';
4c4b4cd2 4619
96d887e8 4620 return scope;
4c4b4cd2
PH
4621}
4622
96d887e8 4623/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 4624
96d887e8
PH
4625static int
4626is_package_name (const char *name)
4c4b4cd2 4627{
96d887e8
PH
4628 /* Here, We take advantage of the fact that no symbols are generated
4629 for packages, while symbols are generated for each function.
4630 So the condition for NAME represent a package becomes equivalent
4631 to NAME not existing in our list of symbols. There is only one
4632 small complication with library-level functions (see below). */
4c4b4cd2 4633
96d887e8 4634 char *fun_name;
76a01679 4635
96d887e8
PH
4636 /* If it is a function that has not been defined at library level,
4637 then we should be able to look it up in the symbols. */
4638 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4639 return 0;
14f9c5c9 4640
96d887e8
PH
4641 /* Library-level function names start with "_ada_". See if function
4642 "_ada_" followed by NAME can be found. */
14f9c5c9 4643
96d887e8 4644 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 4645 functions names cannot contain "__" in them. */
96d887e8
PH
4646 if (strstr (name, "__") != NULL)
4647 return 0;
4c4b4cd2 4648
b435e160 4649 fun_name = xstrprintf ("_ada_%s", name);
14f9c5c9 4650
96d887e8
PH
4651 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4652}
14f9c5c9 4653
96d887e8 4654/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 4655 not visible from FUNCTION_NAME. */
14f9c5c9 4656
96d887e8 4657static int
0d5cff50 4658old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 4659{
aeb5907d
JB
4660 char *scope;
4661
4662 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4663 return 0;
4664
4665 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
d2e4a39e 4666
96d887e8 4667 make_cleanup (xfree, scope);
14f9c5c9 4668
96d887e8
PH
4669 /* If the rename has been defined in a package, then it is visible. */
4670 if (is_package_name (scope))
aeb5907d 4671 return 0;
14f9c5c9 4672
96d887e8
PH
4673 /* Check that the rename is in the current function scope by checking
4674 that its name starts with SCOPE. */
76a01679 4675
96d887e8
PH
4676 /* If the function name starts with "_ada_", it means that it is
4677 a library-level function. Strip this prefix before doing the
4678 comparison, as the encoding for the renaming does not contain
4679 this prefix. */
4680 if (strncmp (function_name, "_ada_", 5) == 0)
4681 function_name += 5;
f26caa11 4682
aeb5907d 4683 return (strncmp (function_name, scope, strlen (scope)) != 0);
f26caa11
PH
4684}
4685
aeb5907d
JB
4686/* Remove entries from SYMS that corresponds to a renaming entity that
4687 is not visible from the function associated with CURRENT_BLOCK or
4688 that is superfluous due to the presence of more specific renaming
4689 information. Places surviving symbols in the initial entries of
4690 SYMS and returns the number of surviving symbols.
96d887e8
PH
4691
4692 Rationale:
aeb5907d
JB
4693 First, in cases where an object renaming is implemented as a
4694 reference variable, GNAT may produce both the actual reference
4695 variable and the renaming encoding. In this case, we discard the
4696 latter.
4697
4698 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
4699 entity. Unfortunately, STABS currently does not support the definition
4700 of types that are local to a given lexical block, so all renamings types
4701 are emitted at library level. As a consequence, if an application
4702 contains two renaming entities using the same name, and a user tries to
4703 print the value of one of these entities, the result of the ada symbol
4704 lookup will also contain the wrong renaming type.
f26caa11 4705
96d887e8
PH
4706 This function partially covers for this limitation by attempting to
4707 remove from the SYMS list renaming symbols that should be visible
4708 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4709 method with the current information available. The implementation
4710 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4711
4712 - When the user tries to print a rename in a function while there
4713 is another rename entity defined in a package: Normally, the
4714 rename in the function has precedence over the rename in the
4715 package, so the latter should be removed from the list. This is
4716 currently not the case.
4717
4718 - This function will incorrectly remove valid renames if
4719 the CURRENT_BLOCK corresponds to a function which symbol name
4720 has been changed by an "Export" pragma. As a consequence,
4721 the user will be unable to print such rename entities. */
4c4b4cd2 4722
14f9c5c9 4723static int
aeb5907d
JB
4724remove_irrelevant_renamings (struct ada_symbol_info *syms,
4725 int nsyms, const struct block *current_block)
4c4b4cd2
PH
4726{
4727 struct symbol *current_function;
0d5cff50 4728 const char *current_function_name;
4c4b4cd2 4729 int i;
aeb5907d
JB
4730 int is_new_style_renaming;
4731
4732 /* If there is both a renaming foo___XR... encoded as a variable and
4733 a simple variable foo in the same block, discard the latter.
0963b4bd 4734 First, zero out such symbols, then compress. */
aeb5907d
JB
4735 is_new_style_renaming = 0;
4736 for (i = 0; i < nsyms; i += 1)
4737 {
4738 struct symbol *sym = syms[i].sym;
4739 struct block *block = syms[i].block;
4740 const char *name;
4741 const char *suffix;
4742
4743 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4744 continue;
4745 name = SYMBOL_LINKAGE_NAME (sym);
4746 suffix = strstr (name, "___XR");
4747
4748 if (suffix != NULL)
4749 {
4750 int name_len = suffix - name;
4751 int j;
5b4ee69b 4752
aeb5907d
JB
4753 is_new_style_renaming = 1;
4754 for (j = 0; j < nsyms; j += 1)
4755 if (i != j && syms[j].sym != NULL
4756 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
4757 name_len) == 0
4758 && block == syms[j].block)
4759 syms[j].sym = NULL;
4760 }
4761 }
4762 if (is_new_style_renaming)
4763 {
4764 int j, k;
4765
4766 for (j = k = 0; j < nsyms; j += 1)
4767 if (syms[j].sym != NULL)
4768 {
4769 syms[k] = syms[j];
4770 k += 1;
4771 }
4772 return k;
4773 }
4c4b4cd2
PH
4774
4775 /* Extract the function name associated to CURRENT_BLOCK.
4776 Abort if unable to do so. */
76a01679 4777
4c4b4cd2
PH
4778 if (current_block == NULL)
4779 return nsyms;
76a01679 4780
7f0df278 4781 current_function = block_linkage_function (current_block);
4c4b4cd2
PH
4782 if (current_function == NULL)
4783 return nsyms;
4784
4785 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
4786 if (current_function_name == NULL)
4787 return nsyms;
4788
4789 /* Check each of the symbols, and remove it from the list if it is
4790 a type corresponding to a renaming that is out of the scope of
4791 the current block. */
4792
4793 i = 0;
4794 while (i < nsyms)
4795 {
aeb5907d
JB
4796 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
4797 == ADA_OBJECT_RENAMING
4798 && old_renaming_is_invisible (syms[i].sym, current_function_name))
4c4b4cd2
PH
4799 {
4800 int j;
5b4ee69b 4801
aeb5907d 4802 for (j = i + 1; j < nsyms; j += 1)
76a01679 4803 syms[j - 1] = syms[j];
4c4b4cd2
PH
4804 nsyms -= 1;
4805 }
4806 else
4807 i += 1;
4808 }
4809
4810 return nsyms;
4811}
4812
339c13b6
JB
4813/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4814 whose name and domain match NAME and DOMAIN respectively.
4815 If no match was found, then extend the search to "enclosing"
4816 routines (in other words, if we're inside a nested function,
4817 search the symbols defined inside the enclosing functions).
4818
4819 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4820
4821static void
4822ada_add_local_symbols (struct obstack *obstackp, const char *name,
4823 struct block *block, domain_enum domain,
4824 int wild_match)
4825{
4826 int block_depth = 0;
4827
4828 while (block != NULL)
4829 {
4830 block_depth += 1;
4831 ada_add_block_symbols (obstackp, block, name, domain, NULL, wild_match);
4832
4833 /* If we found a non-function match, assume that's the one. */
4834 if (is_nonfunction (defns_collected (obstackp, 0),
4835 num_defns_collected (obstackp)))
4836 return;
4837
4838 block = BLOCK_SUPERBLOCK (block);
4839 }
4840
4841 /* If no luck so far, try to find NAME as a local symbol in some lexically
4842 enclosing subprogram. */
4843 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
4844 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match);
4845}
4846
ccefe4c4 4847/* An object of this type is used as the user_data argument when
40658b94 4848 calling the map_matching_symbols method. */
ccefe4c4 4849
40658b94 4850struct match_data
ccefe4c4 4851{
40658b94 4852 struct objfile *objfile;
ccefe4c4 4853 struct obstack *obstackp;
40658b94
PH
4854 struct symbol *arg_sym;
4855 int found_sym;
ccefe4c4
TT
4856};
4857
40658b94
PH
4858/* A callback for add_matching_symbols that adds SYM, found in BLOCK,
4859 to a list of symbols. DATA0 is a pointer to a struct match_data *
4860 containing the obstack that collects the symbol list, the file that SYM
4861 must come from, a flag indicating whether a non-argument symbol has
4862 been found in the current block, and the last argument symbol
4863 passed in SYM within the current block (if any). When SYM is null,
4864 marking the end of a block, the argument symbol is added if no
4865 other has been found. */
ccefe4c4 4866
40658b94
PH
4867static int
4868aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 4869{
40658b94
PH
4870 struct match_data *data = (struct match_data *) data0;
4871
4872 if (sym == NULL)
4873 {
4874 if (!data->found_sym && data->arg_sym != NULL)
4875 add_defn_to_vec (data->obstackp,
4876 fixup_symbol_section (data->arg_sym, data->objfile),
4877 block);
4878 data->found_sym = 0;
4879 data->arg_sym = NULL;
4880 }
4881 else
4882 {
4883 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
4884 return 0;
4885 else if (SYMBOL_IS_ARGUMENT (sym))
4886 data->arg_sym = sym;
4887 else
4888 {
4889 data->found_sym = 1;
4890 add_defn_to_vec (data->obstackp,
4891 fixup_symbol_section (sym, data->objfile),
4892 block);
4893 }
4894 }
4895 return 0;
4896}
4897
4898/* Compare STRING1 to STRING2, with results as for strcmp.
4899 Compatible with strcmp_iw in that strcmp_iw (STRING1, STRING2) <= 0
4900 implies compare_names (STRING1, STRING2) (they may differ as to
4901 what symbols compare equal). */
5b4ee69b 4902
40658b94
PH
4903static int
4904compare_names (const char *string1, const char *string2)
4905{
4906 while (*string1 != '\0' && *string2 != '\0')
4907 {
4908 if (isspace (*string1) || isspace (*string2))
4909 return strcmp_iw_ordered (string1, string2);
4910 if (*string1 != *string2)
4911 break;
4912 string1 += 1;
4913 string2 += 1;
4914 }
4915 switch (*string1)
4916 {
4917 case '(':
4918 return strcmp_iw_ordered (string1, string2);
4919 case '_':
4920 if (*string2 == '\0')
4921 {
052874e8 4922 if (is_name_suffix (string1))
40658b94
PH
4923 return 0;
4924 else
1a1d5513 4925 return 1;
40658b94 4926 }
dbb8534f 4927 /* FALLTHROUGH */
40658b94
PH
4928 default:
4929 if (*string2 == '(')
4930 return strcmp_iw_ordered (string1, string2);
4931 else
4932 return *string1 - *string2;
4933 }
ccefe4c4
TT
4934}
4935
339c13b6
JB
4936/* Add to OBSTACKP all non-local symbols whose name and domain match
4937 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
4938 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
4939
4940static void
40658b94
PH
4941add_nonlocal_symbols (struct obstack *obstackp, const char *name,
4942 domain_enum domain, int global,
4943 int is_wild_match)
339c13b6
JB
4944{
4945 struct objfile *objfile;
40658b94 4946 struct match_data data;
339c13b6 4947
6475f2fe 4948 memset (&data, 0, sizeof data);
ccefe4c4 4949 data.obstackp = obstackp;
339c13b6 4950
ccefe4c4 4951 ALL_OBJFILES (objfile)
40658b94
PH
4952 {
4953 data.objfile = objfile;
4954
4955 if (is_wild_match)
4956 objfile->sf->qf->map_matching_symbols (name, domain, objfile, global,
4957 aux_add_nonlocal_symbols, &data,
4958 wild_match, NULL);
4959 else
4960 objfile->sf->qf->map_matching_symbols (name, domain, objfile, global,
4961 aux_add_nonlocal_symbols, &data,
4962 full_match, compare_names);
4963 }
4964
4965 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
4966 {
4967 ALL_OBJFILES (objfile)
4968 {
4969 char *name1 = alloca (strlen (name) + sizeof ("_ada_"));
4970 strcpy (name1, "_ada_");
4971 strcpy (name1 + sizeof ("_ada_") - 1, name);
4972 data.objfile = objfile;
0963b4bd
MS
4973 objfile->sf->qf->map_matching_symbols (name1, domain,
4974 objfile, global,
4975 aux_add_nonlocal_symbols,
4976 &data,
40658b94
PH
4977 full_match, compare_names);
4978 }
4979 }
339c13b6
JB
4980}
4981
4c4b4cd2
PH
4982/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4983 scope and in global scopes, returning the number of matches. Sets
6c9353d3 4984 *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4c4b4cd2
PH
4985 indicating the symbols found and the blocks and symbol tables (if
4986 any) in which they were found. This vector are transient---good only to
4987 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4988 symbol match within the nest of blocks whose innermost member is BLOCK0,
4989 is the one match returned (no other matches in that or
d9680e73
TT
4990 enclosing blocks is returned). If there are any matches in or
4991 surrounding BLOCK0, then these alone are returned. Otherwise, if
4992 FULL_SEARCH is non-zero, then the search extends to global and
4993 file-scope (static) symbol tables.
4c4b4cd2
PH
4994 Names prefixed with "standard__" are handled specially: "standard__"
4995 is first stripped off, and only static and global symbols are searched. */
14f9c5c9
AS
4996
4997int
4c4b4cd2 4998ada_lookup_symbol_list (const char *name0, const struct block *block0,
d9680e73
TT
4999 domain_enum namespace,
5000 struct ada_symbol_info **results,
5001 int full_search)
14f9c5c9
AS
5002{
5003 struct symbol *sym;
14f9c5c9 5004 struct block *block;
4c4b4cd2 5005 const char *name;
c0431670 5006 const int wild_match = should_use_wild_match (name0);
14f9c5c9 5007 int cacheIfUnique;
4c4b4cd2 5008 int ndefns;
14f9c5c9 5009
4c4b4cd2
PH
5010 obstack_free (&symbol_list_obstack, NULL);
5011 obstack_init (&symbol_list_obstack);
14f9c5c9 5012
14f9c5c9
AS
5013 cacheIfUnique = 0;
5014
5015 /* Search specified block and its superiors. */
5016
4c4b4cd2 5017 name = name0;
76a01679
JB
5018 block = (struct block *) block0; /* FIXME: No cast ought to be
5019 needed, but adding const will
5020 have a cascade effect. */
339c13b6
JB
5021
5022 /* Special case: If the user specifies a symbol name inside package
5023 Standard, do a non-wild matching of the symbol name without
5024 the "standard__" prefix. This was primarily introduced in order
5025 to allow the user to specifically access the standard exceptions
5026 using, for instance, Standard.Constraint_Error when Constraint_Error
5027 is ambiguous (due to the user defining its own Constraint_Error
5028 entity inside its program). */
4c4b4cd2
PH
5029 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
5030 {
4c4b4cd2
PH
5031 block = NULL;
5032 name = name0 + sizeof ("standard__") - 1;
5033 }
5034
339c13b6 5035 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5036
339c13b6
JB
5037 ada_add_local_symbols (&symbol_list_obstack, name, block, namespace,
5038 wild_match);
d9680e73 5039 if (num_defns_collected (&symbol_list_obstack) > 0 || !full_search)
14f9c5c9 5040 goto done;
d2e4a39e 5041
339c13b6
JB
5042 /* No non-global symbols found. Check our cache to see if we have
5043 already performed this search before. If we have, then return
5044 the same result. */
5045
14f9c5c9 5046 cacheIfUnique = 1;
2570f2b7 5047 if (lookup_cached_symbol (name0, namespace, &sym, &block))
4c4b4cd2
PH
5048 {
5049 if (sym != NULL)
2570f2b7 5050 add_defn_to_vec (&symbol_list_obstack, sym, block);
4c4b4cd2
PH
5051 goto done;
5052 }
14f9c5c9 5053
339c13b6
JB
5054 /* Search symbols from all global blocks. */
5055
40658b94
PH
5056 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 1,
5057 wild_match);
d2e4a39e 5058
4c4b4cd2 5059 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5060 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5061
4c4b4cd2 5062 if (num_defns_collected (&symbol_list_obstack) == 0)
40658b94
PH
5063 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 0,
5064 wild_match);
14f9c5c9 5065
4c4b4cd2
PH
5066done:
5067 ndefns = num_defns_collected (&symbol_list_obstack);
5068 *results = defns_collected (&symbol_list_obstack, 1);
5069
5070 ndefns = remove_extra_symbols (*results, ndefns);
5071
2ad01556 5072 if (ndefns == 0 && full_search)
2570f2b7 5073 cache_symbol (name0, namespace, NULL, NULL);
14f9c5c9 5074
2ad01556 5075 if (ndefns == 1 && full_search && cacheIfUnique)
2570f2b7 5076 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
14f9c5c9 5077
aeb5907d 5078 ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
14f9c5c9 5079
14f9c5c9
AS
5080 return ndefns;
5081}
5082
f8eba3c6
TT
5083/* If NAME is the name of an entity, return a string that should
5084 be used to look that entity up in Ada units. This string should
5085 be deallocated after use using xfree.
5086
5087 NAME can have any form that the "break" or "print" commands might
5088 recognize. In other words, it does not have to be the "natural"
5089 name, or the "encoded" name. */
5090
5091char *
5092ada_name_for_lookup (const char *name)
5093{
5094 char *canon;
5095 int nlen = strlen (name);
5096
5097 if (name[0] == '<' && name[nlen - 1] == '>')
5098 {
5099 canon = xmalloc (nlen - 1);
5100 memcpy (canon, name + 1, nlen - 2);
5101 canon[nlen - 2] = '\0';
5102 }
5103 else
5104 canon = xstrdup (ada_encode (ada_fold_name (name)));
5105 return canon;
5106}
5107
5108/* Implementation of the la_iterate_over_symbols method. */
5109
5110static void
5111ada_iterate_over_symbols (const struct block *block,
5112 const char *name, domain_enum domain,
8e704927 5113 symbol_found_callback_ftype *callback,
f8eba3c6
TT
5114 void *data)
5115{
5116 int ndefs, i;
5117 struct ada_symbol_info *results;
5118
d9680e73 5119 ndefs = ada_lookup_symbol_list (name, block, domain, &results, 0);
f8eba3c6
TT
5120 for (i = 0; i < ndefs; ++i)
5121 {
5122 if (! (*callback) (results[i].sym, data))
5123 break;
5124 }
5125}
5126
d2e4a39e 5127struct symbol *
aeb5907d 5128ada_lookup_encoded_symbol (const char *name, const struct block *block0,
21b556f4 5129 domain_enum namespace, struct block **block_found)
14f9c5c9 5130{
4c4b4cd2 5131 struct ada_symbol_info *candidates;
14f9c5c9
AS
5132 int n_candidates;
5133
d9680e73
TT
5134 n_candidates = ada_lookup_symbol_list (name, block0, namespace, &candidates,
5135 1);
14f9c5c9
AS
5136
5137 if (n_candidates == 0)
5138 return NULL;
4c4b4cd2 5139
aeb5907d
JB
5140 if (block_found != NULL)
5141 *block_found = candidates[0].block;
4c4b4cd2 5142
21b556f4 5143 return fixup_symbol_section (candidates[0].sym, NULL);
aeb5907d
JB
5144}
5145
5146/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5147 scope and in global scopes, or NULL if none. NAME is folded and
5148 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5149 choosing the first symbol if there are multiple choices.
aeb5907d
JB
5150 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
5151 table in which the symbol was found (in both cases, these
5152 assignments occur only if the pointers are non-null). */
5153struct symbol *
5154ada_lookup_symbol (const char *name, const struct block *block0,
21b556f4 5155 domain_enum namespace, int *is_a_field_of_this)
aeb5907d
JB
5156{
5157 if (is_a_field_of_this != NULL)
5158 *is_a_field_of_this = 0;
5159
5160 return
5161 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
21b556f4 5162 block0, namespace, NULL);
4c4b4cd2 5163}
14f9c5c9 5164
4c4b4cd2
PH
5165static struct symbol *
5166ada_lookup_symbol_nonlocal (const char *name,
76a01679 5167 const struct block *block,
21b556f4 5168 const domain_enum domain)
4c4b4cd2 5169{
94af9270 5170 return ada_lookup_symbol (name, block_static_block (block), domain, NULL);
14f9c5c9
AS
5171}
5172
5173
4c4b4cd2
PH
5174/* True iff STR is a possible encoded suffix of a normal Ada name
5175 that is to be ignored for matching purposes. Suffixes of parallel
5176 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5177 are given by any of the regular expressions:
4c4b4cd2 5178
babe1480
JB
5179 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5180 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5181 TKB [subprogram suffix for task bodies]
babe1480 5182 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5183 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5184
5185 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5186 match is performed. This sequence is used to differentiate homonyms,
5187 is an optional part of a valid name suffix. */
4c4b4cd2 5188
14f9c5c9 5189static int
d2e4a39e 5190is_name_suffix (const char *str)
14f9c5c9
AS
5191{
5192 int k;
4c4b4cd2
PH
5193 const char *matching;
5194 const int len = strlen (str);
5195
babe1480
JB
5196 /* Skip optional leading __[0-9]+. */
5197
4c4b4cd2
PH
5198 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5199 {
babe1480
JB
5200 str += 3;
5201 while (isdigit (str[0]))
5202 str += 1;
4c4b4cd2 5203 }
babe1480
JB
5204
5205 /* [.$][0-9]+ */
4c4b4cd2 5206
babe1480 5207 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5208 {
babe1480 5209 matching = str + 1;
4c4b4cd2
PH
5210 while (isdigit (matching[0]))
5211 matching += 1;
5212 if (matching[0] == '\0')
5213 return 1;
5214 }
5215
5216 /* ___[0-9]+ */
babe1480 5217
4c4b4cd2
PH
5218 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5219 {
5220 matching = str + 3;
5221 while (isdigit (matching[0]))
5222 matching += 1;
5223 if (matching[0] == '\0')
5224 return 1;
5225 }
5226
9ac7f98e
JB
5227 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5228
5229 if (strcmp (str, "TKB") == 0)
5230 return 1;
5231
529cad9c
PH
5232#if 0
5233 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
5234 with a N at the end. Unfortunately, the compiler uses the same
5235 convention for other internal types it creates. So treating
529cad9c 5236 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
5237 some regressions. For instance, consider the case of an enumerated
5238 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
5239 name ends with N.
5240 Having a single character like this as a suffix carrying some
0963b4bd 5241 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
5242 to be something like "_N" instead. In the meantime, do not do
5243 the following check. */
5244 /* Protected Object Subprograms */
5245 if (len == 1 && str [0] == 'N')
5246 return 1;
5247#endif
5248
5249 /* _E[0-9]+[bs]$ */
5250 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5251 {
5252 matching = str + 3;
5253 while (isdigit (matching[0]))
5254 matching += 1;
5255 if ((matching[0] == 'b' || matching[0] == 's')
5256 && matching [1] == '\0')
5257 return 1;
5258 }
5259
4c4b4cd2
PH
5260 /* ??? We should not modify STR directly, as we are doing below. This
5261 is fine in this case, but may become problematic later if we find
5262 that this alternative did not work, and want to try matching
5263 another one from the begining of STR. Since we modified it, we
5264 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
5265 if (str[0] == 'X')
5266 {
5267 str += 1;
d2e4a39e 5268 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
5269 {
5270 if (str[0] != 'n' && str[0] != 'b')
5271 return 0;
5272 str += 1;
5273 }
14f9c5c9 5274 }
babe1480 5275
14f9c5c9
AS
5276 if (str[0] == '\000')
5277 return 1;
babe1480 5278
d2e4a39e 5279 if (str[0] == '_')
14f9c5c9
AS
5280 {
5281 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 5282 return 0;
d2e4a39e 5283 if (str[2] == '_')
4c4b4cd2 5284 {
61ee279c
PH
5285 if (strcmp (str + 3, "JM") == 0)
5286 return 1;
5287 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5288 the LJM suffix in favor of the JM one. But we will
5289 still accept LJM as a valid suffix for a reasonable
5290 amount of time, just to allow ourselves to debug programs
5291 compiled using an older version of GNAT. */
4c4b4cd2
PH
5292 if (strcmp (str + 3, "LJM") == 0)
5293 return 1;
5294 if (str[3] != 'X')
5295 return 0;
1265e4aa
JB
5296 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5297 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
5298 return 1;
5299 if (str[4] == 'R' && str[5] != 'T')
5300 return 1;
5301 return 0;
5302 }
5303 if (!isdigit (str[2]))
5304 return 0;
5305 for (k = 3; str[k] != '\0'; k += 1)
5306 if (!isdigit (str[k]) && str[k] != '_')
5307 return 0;
14f9c5c9
AS
5308 return 1;
5309 }
4c4b4cd2 5310 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 5311 {
4c4b4cd2
PH
5312 for (k = 2; str[k] != '\0'; k += 1)
5313 if (!isdigit (str[k]) && str[k] != '_')
5314 return 0;
14f9c5c9
AS
5315 return 1;
5316 }
5317 return 0;
5318}
d2e4a39e 5319
aeb5907d
JB
5320/* Return non-zero if the string starting at NAME and ending before
5321 NAME_END contains no capital letters. */
529cad9c
PH
5322
5323static int
5324is_valid_name_for_wild_match (const char *name0)
5325{
5326 const char *decoded_name = ada_decode (name0);
5327 int i;
5328
5823c3ef
JB
5329 /* If the decoded name starts with an angle bracket, it means that
5330 NAME0 does not follow the GNAT encoding format. It should then
5331 not be allowed as a possible wild match. */
5332 if (decoded_name[0] == '<')
5333 return 0;
5334
529cad9c
PH
5335 for (i=0; decoded_name[i] != '\0'; i++)
5336 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5337 return 0;
5338
5339 return 1;
5340}
5341
73589123
PH
5342/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5343 that could start a simple name. Assumes that *NAMEP points into
5344 the string beginning at NAME0. */
4c4b4cd2 5345
14f9c5c9 5346static int
73589123 5347advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 5348{
73589123 5349 const char *name = *namep;
5b4ee69b 5350
5823c3ef 5351 while (1)
14f9c5c9 5352 {
aa27d0b3 5353 int t0, t1;
73589123
PH
5354
5355 t0 = *name;
5356 if (t0 == '_')
5357 {
5358 t1 = name[1];
5359 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5360 {
5361 name += 1;
5362 if (name == name0 + 5 && strncmp (name0, "_ada", 4) == 0)
5363 break;
5364 else
5365 name += 1;
5366 }
aa27d0b3
JB
5367 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5368 || name[2] == target0))
73589123
PH
5369 {
5370 name += 2;
5371 break;
5372 }
5373 else
5374 return 0;
5375 }
5376 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5377 name += 1;
5378 else
5823c3ef 5379 return 0;
73589123
PH
5380 }
5381
5382 *namep = name;
5383 return 1;
5384}
5385
5386/* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5387 informational suffixes of NAME (i.e., for which is_name_suffix is
5388 true). Assumes that PATN is a lower-cased Ada simple name. */
5389
5390static int
5391wild_match (const char *name, const char *patn)
5392{
5393 const char *p, *n;
5394 const char *name0 = name;
5395
5396 while (1)
5397 {
5398 const char *match = name;
5399
5400 if (*name == *patn)
5401 {
5402 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5403 if (*p != *name)
5404 break;
5405 if (*p == '\0' && is_name_suffix (name))
5406 return match != name0 && !is_valid_name_for_wild_match (name0);
5407
5408 if (name[-1] == '_')
5409 name -= 1;
5410 }
5411 if (!advance_wild_match (&name, name0, *patn))
5412 return 1;
96d887e8 5413 }
96d887e8
PH
5414}
5415
40658b94
PH
5416/* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
5417 informational suffix. */
5418
c4d840bd
PH
5419static int
5420full_match (const char *sym_name, const char *search_name)
5421{
40658b94 5422 return !match_name (sym_name, search_name, 0);
c4d840bd
PH
5423}
5424
5425
96d887e8
PH
5426/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5427 vector *defn_symbols, updating the list of symbols in OBSTACKP
0963b4bd 5428 (if necessary). If WILD, treat as NAME with a wildcard prefix.
96d887e8
PH
5429 OBJFILE is the section containing BLOCK.
5430 SYMTAB is recorded with each symbol added. */
5431
5432static void
5433ada_add_block_symbols (struct obstack *obstackp,
76a01679 5434 struct block *block, const char *name,
96d887e8 5435 domain_enum domain, struct objfile *objfile,
2570f2b7 5436 int wild)
96d887e8
PH
5437{
5438 struct dict_iterator iter;
5439 int name_len = strlen (name);
5440 /* A matching argument symbol, if any. */
5441 struct symbol *arg_sym;
5442 /* Set true when we find a matching non-argument symbol. */
5443 int found_sym;
5444 struct symbol *sym;
5445
5446 arg_sym = NULL;
5447 found_sym = 0;
5448 if (wild)
5449 {
c4d840bd
PH
5450 for (sym = dict_iter_match_first (BLOCK_DICT (block), name,
5451 wild_match, &iter);
5452 sym != NULL; sym = dict_iter_match_next (name, wild_match, &iter))
76a01679 5453 {
5eeb2539
AR
5454 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5455 SYMBOL_DOMAIN (sym), domain)
73589123 5456 && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0)
76a01679 5457 {
2a2d4dc3
AS
5458 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5459 continue;
5460 else if (SYMBOL_IS_ARGUMENT (sym))
5461 arg_sym = sym;
5462 else
5463 {
76a01679
JB
5464 found_sym = 1;
5465 add_defn_to_vec (obstackp,
5466 fixup_symbol_section (sym, objfile),
2570f2b7 5467 block);
76a01679
JB
5468 }
5469 }
5470 }
96d887e8
PH
5471 }
5472 else
5473 {
c4d840bd 5474 for (sym = dict_iter_match_first (BLOCK_DICT (block), name,
40658b94 5475 full_match, &iter);
c4d840bd 5476 sym != NULL; sym = dict_iter_match_next (name, full_match, &iter))
76a01679 5477 {
5eeb2539
AR
5478 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5479 SYMBOL_DOMAIN (sym), domain))
76a01679 5480 {
c4d840bd
PH
5481 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5482 {
5483 if (SYMBOL_IS_ARGUMENT (sym))
5484 arg_sym = sym;
5485 else
2a2d4dc3 5486 {
c4d840bd
PH
5487 found_sym = 1;
5488 add_defn_to_vec (obstackp,
5489 fixup_symbol_section (sym, objfile),
5490 block);
2a2d4dc3 5491 }
c4d840bd 5492 }
76a01679
JB
5493 }
5494 }
96d887e8
PH
5495 }
5496
5497 if (!found_sym && arg_sym != NULL)
5498 {
76a01679
JB
5499 add_defn_to_vec (obstackp,
5500 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5501 block);
96d887e8
PH
5502 }
5503
5504 if (!wild)
5505 {
5506 arg_sym = NULL;
5507 found_sym = 0;
5508
5509 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 5510 {
5eeb2539
AR
5511 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5512 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
5513 {
5514 int cmp;
5515
5516 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5517 if (cmp == 0)
5518 {
5519 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5520 if (cmp == 0)
5521 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5522 name_len);
5523 }
5524
5525 if (cmp == 0
5526 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5527 {
2a2d4dc3
AS
5528 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5529 {
5530 if (SYMBOL_IS_ARGUMENT (sym))
5531 arg_sym = sym;
5532 else
5533 {
5534 found_sym = 1;
5535 add_defn_to_vec (obstackp,
5536 fixup_symbol_section (sym, objfile),
5537 block);
5538 }
5539 }
76a01679
JB
5540 }
5541 }
76a01679 5542 }
96d887e8
PH
5543
5544 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5545 They aren't parameters, right? */
5546 if (!found_sym && arg_sym != NULL)
5547 {
5548 add_defn_to_vec (obstackp,
76a01679 5549 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5550 block);
96d887e8
PH
5551 }
5552 }
5553}
5554\f
41d27058
JB
5555
5556 /* Symbol Completion */
5557
5558/* If SYM_NAME is a completion candidate for TEXT, return this symbol
5559 name in a form that's appropriate for the completion. The result
5560 does not need to be deallocated, but is only good until the next call.
5561
5562 TEXT_LEN is equal to the length of TEXT.
5563 Perform a wild match if WILD_MATCH is set.
5564 ENCODED should be set if TEXT represents the start of a symbol name
5565 in its encoded form. */
5566
5567static const char *
5568symbol_completion_match (const char *sym_name,
5569 const char *text, int text_len,
5570 int wild_match, int encoded)
5571{
41d27058
JB
5572 const int verbatim_match = (text[0] == '<');
5573 int match = 0;
5574
5575 if (verbatim_match)
5576 {
5577 /* Strip the leading angle bracket. */
5578 text = text + 1;
5579 text_len--;
5580 }
5581
5582 /* First, test against the fully qualified name of the symbol. */
5583
5584 if (strncmp (sym_name, text, text_len) == 0)
5585 match = 1;
5586
5587 if (match && !encoded)
5588 {
5589 /* One needed check before declaring a positive match is to verify
5590 that iff we are doing a verbatim match, the decoded version
5591 of the symbol name starts with '<'. Otherwise, this symbol name
5592 is not a suitable completion. */
5593 const char *sym_name_copy = sym_name;
5594 int has_angle_bracket;
5595
5596 sym_name = ada_decode (sym_name);
5597 has_angle_bracket = (sym_name[0] == '<');
5598 match = (has_angle_bracket == verbatim_match);
5599 sym_name = sym_name_copy;
5600 }
5601
5602 if (match && !verbatim_match)
5603 {
5604 /* When doing non-verbatim match, another check that needs to
5605 be done is to verify that the potentially matching symbol name
5606 does not include capital letters, because the ada-mode would
5607 not be able to understand these symbol names without the
5608 angle bracket notation. */
5609 const char *tmp;
5610
5611 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5612 if (*tmp != '\0')
5613 match = 0;
5614 }
5615
5616 /* Second: Try wild matching... */
5617
5618 if (!match && wild_match)
5619 {
5620 /* Since we are doing wild matching, this means that TEXT
5621 may represent an unqualified symbol name. We therefore must
5622 also compare TEXT against the unqualified name of the symbol. */
5623 sym_name = ada_unqualified_name (ada_decode (sym_name));
5624
5625 if (strncmp (sym_name, text, text_len) == 0)
5626 match = 1;
5627 }
5628
5629 /* Finally: If we found a mach, prepare the result to return. */
5630
5631 if (!match)
5632 return NULL;
5633
5634 if (verbatim_match)
5635 sym_name = add_angle_brackets (sym_name);
5636
5637 if (!encoded)
5638 sym_name = ada_decode (sym_name);
5639
5640 return sym_name;
5641}
5642
5643/* A companion function to ada_make_symbol_completion_list().
5644 Check if SYM_NAME represents a symbol which name would be suitable
5645 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5646 it is appended at the end of the given string vector SV.
5647
5648 ORIG_TEXT is the string original string from the user command
5649 that needs to be completed. WORD is the entire command on which
5650 completion should be performed. These two parameters are used to
5651 determine which part of the symbol name should be added to the
5652 completion vector.
5653 if WILD_MATCH is set, then wild matching is performed.
5654 ENCODED should be set if TEXT represents a symbol name in its
5655 encoded formed (in which case the completion should also be
5656 encoded). */
5657
5658static void
d6565258 5659symbol_completion_add (VEC(char_ptr) **sv,
41d27058
JB
5660 const char *sym_name,
5661 const char *text, int text_len,
5662 const char *orig_text, const char *word,
5663 int wild_match, int encoded)
5664{
5665 const char *match = symbol_completion_match (sym_name, text, text_len,
5666 wild_match, encoded);
5667 char *completion;
5668
5669 if (match == NULL)
5670 return;
5671
5672 /* We found a match, so add the appropriate completion to the given
5673 string vector. */
5674
5675 if (word == orig_text)
5676 {
5677 completion = xmalloc (strlen (match) + 5);
5678 strcpy (completion, match);
5679 }
5680 else if (word > orig_text)
5681 {
5682 /* Return some portion of sym_name. */
5683 completion = xmalloc (strlen (match) + 5);
5684 strcpy (completion, match + (word - orig_text));
5685 }
5686 else
5687 {
5688 /* Return some of ORIG_TEXT plus sym_name. */
5689 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
5690 strncpy (completion, word, orig_text - word);
5691 completion[orig_text - word] = '\0';
5692 strcat (completion, match);
5693 }
5694
d6565258 5695 VEC_safe_push (char_ptr, *sv, completion);
41d27058
JB
5696}
5697
ccefe4c4 5698/* An object of this type is passed as the user_data argument to the
7b08b9eb 5699 expand_partial_symbol_names method. */
ccefe4c4
TT
5700struct add_partial_datum
5701{
5702 VEC(char_ptr) **completions;
5703 char *text;
5704 int text_len;
5705 char *text0;
5706 char *word;
5707 int wild_match;
5708 int encoded;
5709};
5710
7b08b9eb
JK
5711/* A callback for expand_partial_symbol_names. */
5712static int
e078317b 5713ada_expand_partial_symbol_name (const char *name, void *user_data)
ccefe4c4
TT
5714{
5715 struct add_partial_datum *data = user_data;
7b08b9eb
JK
5716
5717 return symbol_completion_match (name, data->text, data->text_len,
5718 data->wild_match, data->encoded) != NULL;
ccefe4c4
TT
5719}
5720
41d27058
JB
5721/* Return a list of possible symbol names completing TEXT0. The list
5722 is NULL terminated. WORD is the entire command on which completion
5723 is made. */
5724
5725static char **
5726ada_make_symbol_completion_list (char *text0, char *word)
5727{
5728 char *text;
5729 int text_len;
5730 int wild_match;
5731 int encoded;
2ba95b9b 5732 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
41d27058
JB
5733 struct symbol *sym;
5734 struct symtab *s;
41d27058
JB
5735 struct minimal_symbol *msymbol;
5736 struct objfile *objfile;
5737 struct block *b, *surrounding_static_block = 0;
5738 int i;
5739 struct dict_iterator iter;
5740
5741 if (text0[0] == '<')
5742 {
5743 text = xstrdup (text0);
5744 make_cleanup (xfree, text);
5745 text_len = strlen (text);
5746 wild_match = 0;
5747 encoded = 1;
5748 }
5749 else
5750 {
5751 text = xstrdup (ada_encode (text0));
5752 make_cleanup (xfree, text);
5753 text_len = strlen (text);
5754 for (i = 0; i < text_len; i++)
5755 text[i] = tolower (text[i]);
5756
5757 encoded = (strstr (text0, "__") != NULL);
5758 /* If the name contains a ".", then the user is entering a fully
5759 qualified entity name, and the match must not be done in wild
5760 mode. Similarly, if the user wants to complete what looks like
5761 an encoded name, the match must not be done in wild mode. */
5762 wild_match = (strchr (text0, '.') == NULL && !encoded);
5763 }
5764
5765 /* First, look at the partial symtab symbols. */
41d27058 5766 {
ccefe4c4
TT
5767 struct add_partial_datum data;
5768
5769 data.completions = &completions;
5770 data.text = text;
5771 data.text_len = text_len;
5772 data.text0 = text0;
5773 data.word = word;
5774 data.wild_match = wild_match;
5775 data.encoded = encoded;
7b08b9eb 5776 expand_partial_symbol_names (ada_expand_partial_symbol_name, &data);
41d27058
JB
5777 }
5778
5779 /* At this point scan through the misc symbol vectors and add each
5780 symbol you find to the list. Eventually we want to ignore
5781 anything that isn't a text symbol (everything else will be
5782 handled by the psymtab code above). */
5783
5784 ALL_MSYMBOLS (objfile, msymbol)
5785 {
5786 QUIT;
d6565258 5787 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol),
41d27058
JB
5788 text, text_len, text0, word, wild_match, encoded);
5789 }
5790
5791 /* Search upwards from currently selected frame (so that we can
5792 complete on local vars. */
5793
5794 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
5795 {
5796 if (!BLOCK_SUPERBLOCK (b))
5797 surrounding_static_block = b; /* For elmin of dups */
5798
5799 ALL_BLOCK_SYMBOLS (b, iter, sym)
5800 {
d6565258 5801 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058
JB
5802 text, text_len, text0, word,
5803 wild_match, encoded);
5804 }
5805 }
5806
5807 /* Go through the symtabs and check the externs and statics for
5808 symbols which match. */
5809
5810 ALL_SYMTABS (objfile, s)
5811 {
5812 QUIT;
5813 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
5814 ALL_BLOCK_SYMBOLS (b, iter, sym)
5815 {
d6565258 5816 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058
JB
5817 text, text_len, text0, word,
5818 wild_match, encoded);
5819 }
5820 }
5821
5822 ALL_SYMTABS (objfile, s)
5823 {
5824 QUIT;
5825 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
5826 /* Don't do this block twice. */
5827 if (b == surrounding_static_block)
5828 continue;
5829 ALL_BLOCK_SYMBOLS (b, iter, sym)
5830 {
d6565258 5831 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058
JB
5832 text, text_len, text0, word,
5833 wild_match, encoded);
5834 }
5835 }
5836
5837 /* Append the closing NULL entry. */
2ba95b9b 5838 VEC_safe_push (char_ptr, completions, NULL);
41d27058 5839
2ba95b9b
JB
5840 /* Make a copy of the COMPLETIONS VEC before we free it, and then
5841 return the copy. It's unfortunate that we have to make a copy
5842 of an array that we're about to destroy, but there is nothing much
5843 we can do about it. Fortunately, it's typically not a very large
5844 array. */
5845 {
5846 const size_t completions_size =
5847 VEC_length (char_ptr, completions) * sizeof (char *);
dc19db01 5848 char **result = xmalloc (completions_size);
2ba95b9b
JB
5849
5850 memcpy (result, VEC_address (char_ptr, completions), completions_size);
5851
5852 VEC_free (char_ptr, completions);
5853 return result;
5854 }
41d27058
JB
5855}
5856
963a6417 5857 /* Field Access */
96d887e8 5858
73fb9985
JB
5859/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5860 for tagged types. */
5861
5862static int
5863ada_is_dispatch_table_ptr_type (struct type *type)
5864{
0d5cff50 5865 const char *name;
73fb9985
JB
5866
5867 if (TYPE_CODE (type) != TYPE_CODE_PTR)
5868 return 0;
5869
5870 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
5871 if (name == NULL)
5872 return 0;
5873
5874 return (strcmp (name, "ada__tags__dispatch_table") == 0);
5875}
5876
963a6417
PH
5877/* True if field number FIELD_NUM in struct or union type TYPE is supposed
5878 to be invisible to users. */
96d887e8 5879
963a6417
PH
5880int
5881ada_is_ignored_field (struct type *type, int field_num)
96d887e8 5882{
963a6417
PH
5883 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
5884 return 1;
73fb9985
JB
5885
5886 /* Check the name of that field. */
5887 {
5888 const char *name = TYPE_FIELD_NAME (type, field_num);
5889
5890 /* Anonymous field names should not be printed.
5891 brobecker/2007-02-20: I don't think this can actually happen
5892 but we don't want to print the value of annonymous fields anyway. */
5893 if (name == NULL)
5894 return 1;
5895
5896 /* A field named "_parent" is internally generated by GNAT for
5897 tagged types, and should not be printed either. */
5898 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
5899 return 1;
5900 }
5901
5902 /* If this is the dispatch table of a tagged type, then ignore. */
5903 if (ada_is_tagged_type (type, 1)
5904 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num)))
5905 return 1;
5906
5907 /* Not a special field, so it should not be ignored. */
5908 return 0;
963a6417 5909}
96d887e8 5910
963a6417 5911/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 5912 pointer or reference type whose ultimate target has a tag field. */
96d887e8 5913
963a6417
PH
5914int
5915ada_is_tagged_type (struct type *type, int refok)
5916{
5917 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
5918}
96d887e8 5919
963a6417 5920/* True iff TYPE represents the type of X'Tag */
96d887e8 5921
963a6417
PH
5922int
5923ada_is_tag_type (struct type *type)
5924{
5925 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
5926 return 0;
5927 else
96d887e8 5928 {
963a6417 5929 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 5930
963a6417
PH
5931 return (name != NULL
5932 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 5933 }
96d887e8
PH
5934}
5935
963a6417 5936/* The type of the tag on VAL. */
76a01679 5937
963a6417
PH
5938struct type *
5939ada_tag_type (struct value *val)
96d887e8 5940{
df407dfe 5941 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
963a6417 5942}
96d887e8 5943
963a6417 5944/* The value of the tag on VAL. */
96d887e8 5945
963a6417
PH
5946struct value *
5947ada_value_tag (struct value *val)
5948{
03ee6b2e 5949 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
5950}
5951
963a6417
PH
5952/* The value of the tag on the object of type TYPE whose contents are
5953 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 5954 ADDRESS. */
96d887e8 5955
963a6417 5956static struct value *
10a2c479 5957value_tag_from_contents_and_address (struct type *type,
fc1a4b47 5958 const gdb_byte *valaddr,
963a6417 5959 CORE_ADDR address)
96d887e8 5960{
b5385fc0 5961 int tag_byte_offset;
963a6417 5962 struct type *tag_type;
5b4ee69b 5963
963a6417 5964 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 5965 NULL, NULL, NULL))
96d887e8 5966 {
fc1a4b47 5967 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
5968 ? NULL
5969 : valaddr + tag_byte_offset);
963a6417 5970 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 5971
963a6417 5972 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 5973 }
963a6417
PH
5974 return NULL;
5975}
96d887e8 5976
963a6417
PH
5977static struct type *
5978type_from_tag (struct value *tag)
5979{
5980 const char *type_name = ada_tag_name (tag);
5b4ee69b 5981
963a6417
PH
5982 if (type_name != NULL)
5983 return ada_find_any_type (ada_encode (type_name));
5984 return NULL;
5985}
96d887e8 5986
963a6417
PH
5987struct tag_args
5988{
5989 struct value *tag;
5990 char *name;
5991};
4c4b4cd2 5992
529cad9c
PH
5993
5994static int ada_tag_name_1 (void *);
5995static int ada_tag_name_2 (struct tag_args *);
5996
4c4b4cd2 5997/* Wrapper function used by ada_tag_name. Given a struct tag_args*
0963b4bd 5998 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
4c4b4cd2
PH
5999 The value stored in ARGS->name is valid until the next call to
6000 ada_tag_name_1. */
6001
6002static int
6003ada_tag_name_1 (void *args0)
6004{
6005 struct tag_args *args = (struct tag_args *) args0;
6006 static char name[1024];
76a01679 6007 char *p;
4c4b4cd2 6008 struct value *val;
5b4ee69b 6009
4c4b4cd2 6010 args->name = NULL;
03ee6b2e 6011 val = ada_value_struct_elt (args->tag, "tsd", 1);
529cad9c
PH
6012 if (val == NULL)
6013 return ada_tag_name_2 (args);
03ee6b2e 6014 val = ada_value_struct_elt (val, "expanded_name", 1);
529cad9c
PH
6015 if (val == NULL)
6016 return 0;
6017 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6018 for (p = name; *p != '\0'; p += 1)
6019 if (isalpha (*p))
6020 *p = tolower (*p);
6021 args->name = name;
6022 return 0;
6023}
6024
e802dbe0
JB
6025/* Return the "ada__tags__type_specific_data" type. */
6026
6027static struct type *
6028ada_get_tsd_type (struct inferior *inf)
6029{
6030 struct ada_inferior_data *data = get_ada_inferior_data (inf);
6031
6032 if (data->tsd_type == 0)
6033 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6034 return data->tsd_type;
6035}
6036
529cad9c
PH
6037/* Utility function for ada_tag_name_1 that tries the second
6038 representation for the dispatch table (in which there is no
6039 explicit 'tsd' field in the referent of the tag pointer, and instead
0963b4bd 6040 the tsd pointer is stored just before the dispatch table. */
529cad9c
PH
6041
6042static int
6043ada_tag_name_2 (struct tag_args *args)
6044{
6045 struct type *info_type;
6046 static char name[1024];
6047 char *p;
6048 struct value *val, *valp;
6049
6050 args->name = NULL;
e802dbe0 6051 info_type = ada_get_tsd_type (current_inferior());
529cad9c
PH
6052 if (info_type == NULL)
6053 return 0;
6054 info_type = lookup_pointer_type (lookup_pointer_type (info_type));
6055 valp = value_cast (info_type, args->tag);
6056 if (valp == NULL)
6057 return 0;
2497b498 6058 val = value_ind (value_ptradd (valp, -1));
4c4b4cd2
PH
6059 if (val == NULL)
6060 return 0;
03ee6b2e 6061 val = ada_value_struct_elt (val, "expanded_name", 1);
4c4b4cd2
PH
6062 if (val == NULL)
6063 return 0;
6064 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6065 for (p = name; *p != '\0'; p += 1)
6066 if (isalpha (*p))
6067 *p = tolower (*p);
6068 args->name = name;
6069 return 0;
6070}
6071
6072/* The type name of the dynamic type denoted by the 'tag value TAG, as
e802dbe0 6073 a C string. */
4c4b4cd2
PH
6074
6075const char *
6076ada_tag_name (struct value *tag)
6077{
6078 struct tag_args args;
5b4ee69b 6079
df407dfe 6080 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6081 return NULL;
76a01679 6082 args.tag = tag;
4c4b4cd2
PH
6083 args.name = NULL;
6084 catch_errors (ada_tag_name_1, &args, NULL, RETURN_MASK_ALL);
6085 return args.name;
6086}
6087
6088/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6089
d2e4a39e 6090struct type *
ebf56fd3 6091ada_parent_type (struct type *type)
14f9c5c9
AS
6092{
6093 int i;
6094
61ee279c 6095 type = ada_check_typedef (type);
14f9c5c9
AS
6096
6097 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6098 return NULL;
6099
6100 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6101 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6102 {
6103 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6104
6105 /* If the _parent field is a pointer, then dereference it. */
6106 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6107 parent_type = TYPE_TARGET_TYPE (parent_type);
6108 /* If there is a parallel XVS type, get the actual base type. */
6109 parent_type = ada_get_base_type (parent_type);
6110
6111 return ada_check_typedef (parent_type);
6112 }
14f9c5c9
AS
6113
6114 return NULL;
6115}
6116
4c4b4cd2
PH
6117/* True iff field number FIELD_NUM of structure type TYPE contains the
6118 parent-type (inherited) fields of a derived type. Assumes TYPE is
6119 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6120
6121int
ebf56fd3 6122ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6123{
61ee279c 6124 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6125
4c4b4cd2
PH
6126 return (name != NULL
6127 && (strncmp (name, "PARENT", 6) == 0
6128 || strncmp (name, "_parent", 7) == 0));
14f9c5c9
AS
6129}
6130
4c4b4cd2 6131/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6132 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6133 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6134 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6135 structures. */
14f9c5c9
AS
6136
6137int
ebf56fd3 6138ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6139{
d2e4a39e 6140 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6141
d2e4a39e 6142 return (name != NULL
4c4b4cd2
PH
6143 && (strncmp (name, "PARENT", 6) == 0
6144 || strcmp (name, "REP") == 0
6145 || strncmp (name, "_parent", 7) == 0
6146 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6147}
6148
4c4b4cd2
PH
6149/* True iff field number FIELD_NUM of structure or union type TYPE
6150 is a variant wrapper. Assumes TYPE is a structure type with at least
6151 FIELD_NUM+1 fields. */
14f9c5c9
AS
6152
6153int
ebf56fd3 6154ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6155{
d2e4a39e 6156 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6157
14f9c5c9 6158 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6159 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6160 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6161 == TYPE_CODE_UNION)));
14f9c5c9
AS
6162}
6163
6164/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6165 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6166 returns the type of the controlling discriminant for the variant.
6167 May return NULL if the type could not be found. */
14f9c5c9 6168
d2e4a39e 6169struct type *
ebf56fd3 6170ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6171{
d2e4a39e 6172 char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6173
7c964f07 6174 return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
14f9c5c9
AS
6175}
6176
4c4b4cd2 6177/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6178 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6179 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6180
6181int
ebf56fd3 6182ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6183{
d2e4a39e 6184 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6185
14f9c5c9
AS
6186 return (name != NULL && name[0] == 'O');
6187}
6188
6189/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
6190 returns the name of the discriminant controlling the variant.
6191 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 6192
d2e4a39e 6193char *
ebf56fd3 6194ada_variant_discrim_name (struct type *type0)
14f9c5c9 6195{
d2e4a39e 6196 static char *result = NULL;
14f9c5c9 6197 static size_t result_len = 0;
d2e4a39e
AS
6198 struct type *type;
6199 const char *name;
6200 const char *discrim_end;
6201 const char *discrim_start;
14f9c5c9
AS
6202
6203 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6204 type = TYPE_TARGET_TYPE (type0);
6205 else
6206 type = type0;
6207
6208 name = ada_type_name (type);
6209
6210 if (name == NULL || name[0] == '\000')
6211 return "";
6212
6213 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6214 discrim_end -= 1)
6215 {
4c4b4cd2
PH
6216 if (strncmp (discrim_end, "___XVN", 6) == 0)
6217 break;
14f9c5c9
AS
6218 }
6219 if (discrim_end == name)
6220 return "";
6221
d2e4a39e 6222 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
6223 discrim_start -= 1)
6224 {
d2e4a39e 6225 if (discrim_start == name + 1)
4c4b4cd2 6226 return "";
76a01679 6227 if ((discrim_start > name + 3
4c4b4cd2
PH
6228 && strncmp (discrim_start - 3, "___", 3) == 0)
6229 || discrim_start[-1] == '.')
6230 break;
14f9c5c9
AS
6231 }
6232
6233 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6234 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 6235 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
6236 return result;
6237}
6238
4c4b4cd2
PH
6239/* Scan STR for a subtype-encoded number, beginning at position K.
6240 Put the position of the character just past the number scanned in
6241 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6242 Return 1 if there was a valid number at the given position, and 0
6243 otherwise. A "subtype-encoded" number consists of the absolute value
6244 in decimal, followed by the letter 'm' to indicate a negative number.
6245 Assumes 0m does not occur. */
14f9c5c9
AS
6246
6247int
d2e4a39e 6248ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
6249{
6250 ULONGEST RU;
6251
d2e4a39e 6252 if (!isdigit (str[k]))
14f9c5c9
AS
6253 return 0;
6254
4c4b4cd2 6255 /* Do it the hard way so as not to make any assumption about
14f9c5c9 6256 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 6257 LONGEST. */
14f9c5c9
AS
6258 RU = 0;
6259 while (isdigit (str[k]))
6260 {
d2e4a39e 6261 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
6262 k += 1;
6263 }
6264
d2e4a39e 6265 if (str[k] == 'm')
14f9c5c9
AS
6266 {
6267 if (R != NULL)
4c4b4cd2 6268 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
6269 k += 1;
6270 }
6271 else if (R != NULL)
6272 *R = (LONGEST) RU;
6273
4c4b4cd2 6274 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
6275 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6276 number representable as a LONGEST (although either would probably work
6277 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 6278 above is always equivalent to the negative of RU. */
14f9c5c9
AS
6279
6280 if (new_k != NULL)
6281 *new_k = k;
6282 return 1;
6283}
6284
4c4b4cd2
PH
6285/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6286 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6287 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 6288
d2e4a39e 6289int
ebf56fd3 6290ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 6291{
d2e4a39e 6292 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
6293 int p;
6294
6295 p = 0;
6296 while (1)
6297 {
d2e4a39e 6298 switch (name[p])
4c4b4cd2
PH
6299 {
6300 case '\0':
6301 return 0;
6302 case 'S':
6303 {
6304 LONGEST W;
5b4ee69b 6305
4c4b4cd2
PH
6306 if (!ada_scan_number (name, p + 1, &W, &p))
6307 return 0;
6308 if (val == W)
6309 return 1;
6310 break;
6311 }
6312 case 'R':
6313 {
6314 LONGEST L, U;
5b4ee69b 6315
4c4b4cd2
PH
6316 if (!ada_scan_number (name, p + 1, &L, &p)
6317 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6318 return 0;
6319 if (val >= L && val <= U)
6320 return 1;
6321 break;
6322 }
6323 case 'O':
6324 return 1;
6325 default:
6326 return 0;
6327 }
6328 }
6329}
6330
0963b4bd 6331/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
6332
6333/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6334 ARG_TYPE, extract and return the value of one of its (non-static)
6335 fields. FIELDNO says which field. Differs from value_primitive_field
6336 only in that it can handle packed values of arbitrary type. */
14f9c5c9 6337
4c4b4cd2 6338static struct value *
d2e4a39e 6339ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 6340 struct type *arg_type)
14f9c5c9 6341{
14f9c5c9
AS
6342 struct type *type;
6343
61ee279c 6344 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
6345 type = TYPE_FIELD_TYPE (arg_type, fieldno);
6346
4c4b4cd2 6347 /* Handle packed fields. */
14f9c5c9
AS
6348
6349 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
6350 {
6351 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6352 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 6353
0fd88904 6354 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
6355 offset + bit_pos / 8,
6356 bit_pos % 8, bit_size, type);
14f9c5c9
AS
6357 }
6358 else
6359 return value_primitive_field (arg1, offset, fieldno, arg_type);
6360}
6361
52ce6436
PH
6362/* Find field with name NAME in object of type TYPE. If found,
6363 set the following for each argument that is non-null:
6364 - *FIELD_TYPE_P to the field's type;
6365 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6366 an object of that type;
6367 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6368 - *BIT_SIZE_P to its size in bits if the field is packed, and
6369 0 otherwise;
6370 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6371 fields up to but not including the desired field, or by the total
6372 number of fields if not found. A NULL value of NAME never
6373 matches; the function just counts visible fields in this case.
6374
0963b4bd 6375 Returns 1 if found, 0 otherwise. */
52ce6436 6376
4c4b4cd2 6377static int
0d5cff50 6378find_struct_field (const char *name, struct type *type, int offset,
76a01679 6379 struct type **field_type_p,
52ce6436
PH
6380 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6381 int *index_p)
4c4b4cd2
PH
6382{
6383 int i;
6384
61ee279c 6385 type = ada_check_typedef (type);
76a01679 6386
52ce6436
PH
6387 if (field_type_p != NULL)
6388 *field_type_p = NULL;
6389 if (byte_offset_p != NULL)
d5d6fca5 6390 *byte_offset_p = 0;
52ce6436
PH
6391 if (bit_offset_p != NULL)
6392 *bit_offset_p = 0;
6393 if (bit_size_p != NULL)
6394 *bit_size_p = 0;
6395
6396 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
6397 {
6398 int bit_pos = TYPE_FIELD_BITPOS (type, i);
6399 int fld_offset = offset + bit_pos / 8;
0d5cff50 6400 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 6401
4c4b4cd2
PH
6402 if (t_field_name == NULL)
6403 continue;
6404
52ce6436 6405 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
6406 {
6407 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 6408
52ce6436
PH
6409 if (field_type_p != NULL)
6410 *field_type_p = TYPE_FIELD_TYPE (type, i);
6411 if (byte_offset_p != NULL)
6412 *byte_offset_p = fld_offset;
6413 if (bit_offset_p != NULL)
6414 *bit_offset_p = bit_pos % 8;
6415 if (bit_size_p != NULL)
6416 *bit_size_p = bit_size;
76a01679
JB
6417 return 1;
6418 }
4c4b4cd2
PH
6419 else if (ada_is_wrapper_field (type, i))
6420 {
52ce6436
PH
6421 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
6422 field_type_p, byte_offset_p, bit_offset_p,
6423 bit_size_p, index_p))
76a01679
JB
6424 return 1;
6425 }
4c4b4cd2
PH
6426 else if (ada_is_variant_part (type, i))
6427 {
52ce6436
PH
6428 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6429 fixed type?? */
4c4b4cd2 6430 int j;
52ce6436
PH
6431 struct type *field_type
6432 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 6433
52ce6436 6434 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6435 {
76a01679
JB
6436 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
6437 fld_offset
6438 + TYPE_FIELD_BITPOS (field_type, j) / 8,
6439 field_type_p, byte_offset_p,
52ce6436 6440 bit_offset_p, bit_size_p, index_p))
76a01679 6441 return 1;
4c4b4cd2
PH
6442 }
6443 }
52ce6436
PH
6444 else if (index_p != NULL)
6445 *index_p += 1;
4c4b4cd2
PH
6446 }
6447 return 0;
6448}
6449
0963b4bd 6450/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 6451
52ce6436
PH
6452static int
6453num_visible_fields (struct type *type)
6454{
6455 int n;
5b4ee69b 6456
52ce6436
PH
6457 n = 0;
6458 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6459 return n;
6460}
14f9c5c9 6461
4c4b4cd2 6462/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
6463 and search in it assuming it has (class) type TYPE.
6464 If found, return value, else return NULL.
6465
4c4b4cd2 6466 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 6467
4c4b4cd2 6468static struct value *
d2e4a39e 6469ada_search_struct_field (char *name, struct value *arg, int offset,
4c4b4cd2 6470 struct type *type)
14f9c5c9
AS
6471{
6472 int i;
14f9c5c9 6473
5b4ee69b 6474 type = ada_check_typedef (type);
52ce6436 6475 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 6476 {
0d5cff50 6477 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
6478
6479 if (t_field_name == NULL)
4c4b4cd2 6480 continue;
14f9c5c9
AS
6481
6482 else if (field_name_match (t_field_name, name))
4c4b4cd2 6483 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
6484
6485 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 6486 {
0963b4bd 6487 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
6488 ada_search_struct_field (name, arg,
6489 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6490 TYPE_FIELD_TYPE (type, i));
5b4ee69b 6491
4c4b4cd2
PH
6492 if (v != NULL)
6493 return v;
6494 }
14f9c5c9
AS
6495
6496 else if (ada_is_variant_part (type, i))
4c4b4cd2 6497 {
0963b4bd 6498 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 6499 int j;
5b4ee69b
MS
6500 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
6501 i));
4c4b4cd2
PH
6502 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6503
52ce6436 6504 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6505 {
0963b4bd
MS
6506 struct value *v = ada_search_struct_field /* Force line
6507 break. */
06d5cf63
JB
6508 (name, arg,
6509 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6510 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 6511
4c4b4cd2
PH
6512 if (v != NULL)
6513 return v;
6514 }
6515 }
14f9c5c9
AS
6516 }
6517 return NULL;
6518}
d2e4a39e 6519
52ce6436
PH
6520static struct value *ada_index_struct_field_1 (int *, struct value *,
6521 int, struct type *);
6522
6523
6524/* Return field #INDEX in ARG, where the index is that returned by
6525 * find_struct_field through its INDEX_P argument. Adjust the address
6526 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 6527 * If found, return value, else return NULL. */
52ce6436
PH
6528
6529static struct value *
6530ada_index_struct_field (int index, struct value *arg, int offset,
6531 struct type *type)
6532{
6533 return ada_index_struct_field_1 (&index, arg, offset, type);
6534}
6535
6536
6537/* Auxiliary function for ada_index_struct_field. Like
6538 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 6539 * *INDEX_P. */
52ce6436
PH
6540
6541static struct value *
6542ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6543 struct type *type)
6544{
6545 int i;
6546 type = ada_check_typedef (type);
6547
6548 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6549 {
6550 if (TYPE_FIELD_NAME (type, i) == NULL)
6551 continue;
6552 else if (ada_is_wrapper_field (type, i))
6553 {
0963b4bd 6554 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
6555 ada_index_struct_field_1 (index_p, arg,
6556 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6557 TYPE_FIELD_TYPE (type, i));
5b4ee69b 6558
52ce6436
PH
6559 if (v != NULL)
6560 return v;
6561 }
6562
6563 else if (ada_is_variant_part (type, i))
6564 {
6565 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 6566 find_struct_field. */
52ce6436
PH
6567 error (_("Cannot assign this kind of variant record"));
6568 }
6569 else if (*index_p == 0)
6570 return ada_value_primitive_field (arg, offset, i, type);
6571 else
6572 *index_p -= 1;
6573 }
6574 return NULL;
6575}
6576
4c4b4cd2
PH
6577/* Given ARG, a value of type (pointer or reference to a)*
6578 structure/union, extract the component named NAME from the ultimate
6579 target structure/union and return it as a value with its
f5938064 6580 appropriate type.
14f9c5c9 6581
4c4b4cd2
PH
6582 The routine searches for NAME among all members of the structure itself
6583 and (recursively) among all members of any wrapper members
14f9c5c9
AS
6584 (e.g., '_parent').
6585
03ee6b2e
PH
6586 If NO_ERR, then simply return NULL in case of error, rather than
6587 calling error. */
14f9c5c9 6588
d2e4a39e 6589struct value *
03ee6b2e 6590ada_value_struct_elt (struct value *arg, char *name, int no_err)
14f9c5c9 6591{
4c4b4cd2 6592 struct type *t, *t1;
d2e4a39e 6593 struct value *v;
14f9c5c9 6594
4c4b4cd2 6595 v = NULL;
df407dfe 6596 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
6597 if (TYPE_CODE (t) == TYPE_CODE_REF)
6598 {
6599 t1 = TYPE_TARGET_TYPE (t);
6600 if (t1 == NULL)
03ee6b2e 6601 goto BadValue;
61ee279c 6602 t1 = ada_check_typedef (t1);
4c4b4cd2 6603 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 6604 {
994b9211 6605 arg = coerce_ref (arg);
76a01679
JB
6606 t = t1;
6607 }
4c4b4cd2 6608 }
14f9c5c9 6609
4c4b4cd2
PH
6610 while (TYPE_CODE (t) == TYPE_CODE_PTR)
6611 {
6612 t1 = TYPE_TARGET_TYPE (t);
6613 if (t1 == NULL)
03ee6b2e 6614 goto BadValue;
61ee279c 6615 t1 = ada_check_typedef (t1);
4c4b4cd2 6616 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
6617 {
6618 arg = value_ind (arg);
6619 t = t1;
6620 }
4c4b4cd2 6621 else
76a01679 6622 break;
4c4b4cd2 6623 }
14f9c5c9 6624
4c4b4cd2 6625 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 6626 goto BadValue;
14f9c5c9 6627
4c4b4cd2
PH
6628 if (t1 == t)
6629 v = ada_search_struct_field (name, arg, 0, t);
6630 else
6631 {
6632 int bit_offset, bit_size, byte_offset;
6633 struct type *field_type;
6634 CORE_ADDR address;
6635
76a01679
JB
6636 if (TYPE_CODE (t) == TYPE_CODE_PTR)
6637 address = value_as_address (arg);
4c4b4cd2 6638 else
0fd88904 6639 address = unpack_pointer (t, value_contents (arg));
14f9c5c9 6640
1ed6ede0 6641 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
76a01679
JB
6642 if (find_struct_field (name, t1, 0,
6643 &field_type, &byte_offset, &bit_offset,
52ce6436 6644 &bit_size, NULL))
76a01679
JB
6645 {
6646 if (bit_size != 0)
6647 {
714e53ab
PH
6648 if (TYPE_CODE (t) == TYPE_CODE_REF)
6649 arg = ada_coerce_ref (arg);
6650 else
6651 arg = ada_value_ind (arg);
76a01679
JB
6652 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
6653 bit_offset, bit_size,
6654 field_type);
6655 }
6656 else
f5938064 6657 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
6658 }
6659 }
6660
03ee6b2e
PH
6661 if (v != NULL || no_err)
6662 return v;
6663 else
323e0a4a 6664 error (_("There is no member named %s."), name);
14f9c5c9 6665
03ee6b2e
PH
6666 BadValue:
6667 if (no_err)
6668 return NULL;
6669 else
0963b4bd
MS
6670 error (_("Attempt to extract a component of "
6671 "a value that is not a record."));
14f9c5c9
AS
6672}
6673
6674/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
6675 If DISPP is non-null, add its byte displacement from the beginning of a
6676 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
6677 work for packed fields).
6678
6679 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 6680 followed by "___".
14f9c5c9 6681
0963b4bd 6682 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
6683 be a (pointer or reference)+ to a struct or union, and the
6684 ultimate target type will be searched.
14f9c5c9
AS
6685
6686 Looks recursively into variant clauses and parent types.
6687
4c4b4cd2
PH
6688 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6689 TYPE is not a type of the right kind. */
14f9c5c9 6690
4c4b4cd2 6691static struct type *
76a01679
JB
6692ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
6693 int noerr, int *dispp)
14f9c5c9
AS
6694{
6695 int i;
6696
6697 if (name == NULL)
6698 goto BadName;
6699
76a01679 6700 if (refok && type != NULL)
4c4b4cd2
PH
6701 while (1)
6702 {
61ee279c 6703 type = ada_check_typedef (type);
76a01679
JB
6704 if (TYPE_CODE (type) != TYPE_CODE_PTR
6705 && TYPE_CODE (type) != TYPE_CODE_REF)
6706 break;
6707 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 6708 }
14f9c5c9 6709
76a01679 6710 if (type == NULL
1265e4aa
JB
6711 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
6712 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 6713 {
4c4b4cd2 6714 if (noerr)
76a01679 6715 return NULL;
4c4b4cd2 6716 else
76a01679
JB
6717 {
6718 target_terminal_ours ();
6719 gdb_flush (gdb_stdout);
323e0a4a
AC
6720 if (type == NULL)
6721 error (_("Type (null) is not a structure or union type"));
6722 else
6723 {
6724 /* XXX: type_sprint */
6725 fprintf_unfiltered (gdb_stderr, _("Type "));
6726 type_print (type, "", gdb_stderr, -1);
6727 error (_(" is not a structure or union type"));
6728 }
76a01679 6729 }
14f9c5c9
AS
6730 }
6731
6732 type = to_static_fixed_type (type);
6733
6734 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6735 {
0d5cff50 6736 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
6737 struct type *t;
6738 int disp;
d2e4a39e 6739
14f9c5c9 6740 if (t_field_name == NULL)
4c4b4cd2 6741 continue;
14f9c5c9
AS
6742
6743 else if (field_name_match (t_field_name, name))
4c4b4cd2
PH
6744 {
6745 if (dispp != NULL)
6746 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
61ee279c 6747 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 6748 }
14f9c5c9
AS
6749
6750 else if (ada_is_wrapper_field (type, i))
4c4b4cd2
PH
6751 {
6752 disp = 0;
6753 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
6754 0, 1, &disp);
6755 if (t != NULL)
6756 {
6757 if (dispp != NULL)
6758 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6759 return t;
6760 }
6761 }
14f9c5c9
AS
6762
6763 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
6764 {
6765 int j;
5b4ee69b
MS
6766 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
6767 i));
4c4b4cd2
PH
6768
6769 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
6770 {
b1f33ddd
JB
6771 /* FIXME pnh 2008/01/26: We check for a field that is
6772 NOT wrapped in a struct, since the compiler sometimes
6773 generates these for unchecked variant types. Revisit
0963b4bd 6774 if the compiler changes this practice. */
0d5cff50 6775 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
4c4b4cd2 6776 disp = 0;
b1f33ddd
JB
6777 if (v_field_name != NULL
6778 && field_name_match (v_field_name, name))
6779 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
6780 else
0963b4bd
MS
6781 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
6782 j),
b1f33ddd
JB
6783 name, 0, 1, &disp);
6784
4c4b4cd2
PH
6785 if (t != NULL)
6786 {
6787 if (dispp != NULL)
6788 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6789 return t;
6790 }
6791 }
6792 }
14f9c5c9
AS
6793
6794 }
6795
6796BadName:
d2e4a39e 6797 if (!noerr)
14f9c5c9
AS
6798 {
6799 target_terminal_ours ();
6800 gdb_flush (gdb_stdout);
323e0a4a
AC
6801 if (name == NULL)
6802 {
6803 /* XXX: type_sprint */
6804 fprintf_unfiltered (gdb_stderr, _("Type "));
6805 type_print (type, "", gdb_stderr, -1);
6806 error (_(" has no component named <null>"));
6807 }
6808 else
6809 {
6810 /* XXX: type_sprint */
6811 fprintf_unfiltered (gdb_stderr, _("Type "));
6812 type_print (type, "", gdb_stderr, -1);
6813 error (_(" has no component named %s"), name);
6814 }
14f9c5c9
AS
6815 }
6816
6817 return NULL;
6818}
6819
b1f33ddd
JB
6820/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6821 within a value of type OUTER_TYPE, return true iff VAR_TYPE
6822 represents an unchecked union (that is, the variant part of a
0963b4bd 6823 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
6824
6825static int
6826is_unchecked_variant (struct type *var_type, struct type *outer_type)
6827{
6828 char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 6829
b1f33ddd
JB
6830 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
6831 == NULL);
6832}
6833
6834
14f9c5c9
AS
6835/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6836 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
6837 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6838 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 6839
d2e4a39e 6840int
ebf56fd3 6841ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 6842 const gdb_byte *outer_valaddr)
14f9c5c9
AS
6843{
6844 int others_clause;
6845 int i;
d2e4a39e 6846 char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
6847 struct value *outer;
6848 struct value *discrim;
14f9c5c9
AS
6849 LONGEST discrim_val;
6850
0c281816
JB
6851 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
6852 discrim = ada_value_struct_elt (outer, discrim_name, 1);
6853 if (discrim == NULL)
14f9c5c9 6854 return -1;
0c281816 6855 discrim_val = value_as_long (discrim);
14f9c5c9
AS
6856
6857 others_clause = -1;
6858 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
6859 {
6860 if (ada_is_others_clause (var_type, i))
4c4b4cd2 6861 others_clause = i;
14f9c5c9 6862 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 6863 return i;
14f9c5c9
AS
6864 }
6865
6866 return others_clause;
6867}
d2e4a39e 6868\f
14f9c5c9
AS
6869
6870
4c4b4cd2 6871 /* Dynamic-Sized Records */
14f9c5c9
AS
6872
6873/* Strategy: The type ostensibly attached to a value with dynamic size
6874 (i.e., a size that is not statically recorded in the debugging
6875 data) does not accurately reflect the size or layout of the value.
6876 Our strategy is to convert these values to values with accurate,
4c4b4cd2 6877 conventional types that are constructed on the fly. */
14f9c5c9
AS
6878
6879/* There is a subtle and tricky problem here. In general, we cannot
6880 determine the size of dynamic records without its data. However,
6881 the 'struct value' data structure, which GDB uses to represent
6882 quantities in the inferior process (the target), requires the size
6883 of the type at the time of its allocation in order to reserve space
6884 for GDB's internal copy of the data. That's why the
6885 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 6886 rather than struct value*s.
14f9c5c9
AS
6887
6888 However, GDB's internal history variables ($1, $2, etc.) are
6889 struct value*s containing internal copies of the data that are not, in
6890 general, the same as the data at their corresponding addresses in
6891 the target. Fortunately, the types we give to these values are all
6892 conventional, fixed-size types (as per the strategy described
6893 above), so that we don't usually have to perform the
6894 'to_fixed_xxx_type' conversions to look at their values.
6895 Unfortunately, there is one exception: if one of the internal
6896 history variables is an array whose elements are unconstrained
6897 records, then we will need to create distinct fixed types for each
6898 element selected. */
6899
6900/* The upshot of all of this is that many routines take a (type, host
6901 address, target address) triple as arguments to represent a value.
6902 The host address, if non-null, is supposed to contain an internal
6903 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 6904 target at the target address. */
14f9c5c9
AS
6905
6906/* Assuming that VAL0 represents a pointer value, the result of
6907 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 6908 dynamic-sized types. */
14f9c5c9 6909
d2e4a39e
AS
6910struct value *
6911ada_value_ind (struct value *val0)
14f9c5c9 6912{
c48db5ca 6913 struct value *val = value_ind (val0);
5b4ee69b 6914
4c4b4cd2 6915 return ada_to_fixed_value (val);
14f9c5c9
AS
6916}
6917
6918/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
6919 qualifiers on VAL0. */
6920
d2e4a39e
AS
6921static struct value *
6922ada_coerce_ref (struct value *val0)
6923{
df407dfe 6924 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
6925 {
6926 struct value *val = val0;
5b4ee69b 6927
994b9211 6928 val = coerce_ref (val);
4c4b4cd2 6929 return ada_to_fixed_value (val);
d2e4a39e
AS
6930 }
6931 else
14f9c5c9
AS
6932 return val0;
6933}
6934
6935/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 6936 ALIGNMENT (a power of 2). */
14f9c5c9
AS
6937
6938static unsigned int
ebf56fd3 6939align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
6940{
6941 return (off + alignment - 1) & ~(alignment - 1);
6942}
6943
4c4b4cd2 6944/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
6945
6946static unsigned int
ebf56fd3 6947field_alignment (struct type *type, int f)
14f9c5c9 6948{
d2e4a39e 6949 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 6950 int len;
14f9c5c9
AS
6951 int align_offset;
6952
64a1bf19
JB
6953 /* The field name should never be null, unless the debugging information
6954 is somehow malformed. In this case, we assume the field does not
6955 require any alignment. */
6956 if (name == NULL)
6957 return 1;
6958
6959 len = strlen (name);
6960
4c4b4cd2
PH
6961 if (!isdigit (name[len - 1]))
6962 return 1;
14f9c5c9 6963
d2e4a39e 6964 if (isdigit (name[len - 2]))
14f9c5c9
AS
6965 align_offset = len - 2;
6966 else
6967 align_offset = len - 1;
6968
4c4b4cd2 6969 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
14f9c5c9
AS
6970 return TARGET_CHAR_BIT;
6971
4c4b4cd2
PH
6972 return atoi (name + align_offset) * TARGET_CHAR_BIT;
6973}
6974
6975/* Find a symbol named NAME. Ignores ambiguity. */
6976
6977struct symbol *
6978ada_find_any_symbol (const char *name)
6979{
6980 struct symbol *sym;
6981
6982 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
6983 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
6984 return sym;
6985
6986 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
6987 return sym;
14f9c5c9
AS
6988}
6989
dddfab26
UW
6990/* Find a type named NAME. Ignores ambiguity. This routine will look
6991 solely for types defined by debug info, it will not search the GDB
6992 primitive types. */
4c4b4cd2 6993
d2e4a39e 6994struct type *
ebf56fd3 6995ada_find_any_type (const char *name)
14f9c5c9 6996{
4c4b4cd2 6997 struct symbol *sym = ada_find_any_symbol (name);
14f9c5c9 6998
14f9c5c9 6999 if (sym != NULL)
dddfab26 7000 return SYMBOL_TYPE (sym);
14f9c5c9 7001
dddfab26 7002 return NULL;
14f9c5c9
AS
7003}
7004
aeb5907d
JB
7005/* Given NAME and an associated BLOCK, search all symbols for
7006 NAME suffixed with "___XR", which is the ``renaming'' symbol
4c4b4cd2
PH
7007 associated to NAME. Return this symbol if found, return
7008 NULL otherwise. */
7009
7010struct symbol *
7011ada_find_renaming_symbol (const char *name, struct block *block)
aeb5907d
JB
7012{
7013 struct symbol *sym;
7014
7015 sym = find_old_style_renaming_symbol (name, block);
7016
7017 if (sym != NULL)
7018 return sym;
7019
0963b4bd 7020 /* Not right yet. FIXME pnh 7/20/2007. */
aeb5907d
JB
7021 sym = ada_find_any_symbol (name);
7022 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7023 return sym;
7024 else
7025 return NULL;
7026}
7027
7028static struct symbol *
7029find_old_style_renaming_symbol (const char *name, struct block *block)
4c4b4cd2 7030{
7f0df278 7031 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
7032 char *rename;
7033
7034 if (function_sym != NULL)
7035 {
7036 /* If the symbol is defined inside a function, NAME is not fully
7037 qualified. This means we need to prepend the function name
7038 as well as adding the ``___XR'' suffix to build the name of
7039 the associated renaming symbol. */
0d5cff50 7040 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
7041 /* Function names sometimes contain suffixes used
7042 for instance to qualify nested subprograms. When building
7043 the XR type name, we need to make sure that this suffix is
7044 not included. So do not include any suffix in the function
7045 name length below. */
69fadcdf 7046 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
7047 const int rename_len = function_name_len + 2 /* "__" */
7048 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 7049
529cad9c 7050 /* Strip the suffix if necessary. */
69fadcdf
JB
7051 ada_remove_trailing_digits (function_name, &function_name_len);
7052 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7053 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 7054
4c4b4cd2
PH
7055 /* Library-level functions are a special case, as GNAT adds
7056 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 7057 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
7058 have this prefix, so we need to skip this prefix if present. */
7059 if (function_name_len > 5 /* "_ada_" */
7060 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
7061 {
7062 function_name += 5;
7063 function_name_len -= 5;
7064 }
4c4b4cd2
PH
7065
7066 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
7067 strncpy (rename, function_name, function_name_len);
7068 xsnprintf (rename + function_name_len, rename_len - function_name_len,
7069 "__%s___XR", name);
4c4b4cd2
PH
7070 }
7071 else
7072 {
7073 const int rename_len = strlen (name) + 6;
5b4ee69b 7074
4c4b4cd2 7075 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 7076 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
7077 }
7078
7079 return ada_find_any_symbol (rename);
7080}
7081
14f9c5c9 7082/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 7083 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 7084 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
7085 otherwise return 0. */
7086
14f9c5c9 7087int
d2e4a39e 7088ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
7089{
7090 if (type1 == NULL)
7091 return 1;
7092 else if (type0 == NULL)
7093 return 0;
7094 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7095 return 1;
7096 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7097 return 0;
4c4b4cd2
PH
7098 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7099 return 1;
ad82864c 7100 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 7101 return 1;
4c4b4cd2
PH
7102 else if (ada_is_array_descriptor_type (type0)
7103 && !ada_is_array_descriptor_type (type1))
14f9c5c9 7104 return 1;
aeb5907d
JB
7105 else
7106 {
7107 const char *type0_name = type_name_no_tag (type0);
7108 const char *type1_name = type_name_no_tag (type1);
7109
7110 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7111 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7112 return 1;
7113 }
14f9c5c9
AS
7114 return 0;
7115}
7116
7117/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
7118 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7119
0d5cff50 7120const char *
d2e4a39e 7121ada_type_name (struct type *type)
14f9c5c9 7122{
d2e4a39e 7123 if (type == NULL)
14f9c5c9
AS
7124 return NULL;
7125 else if (TYPE_NAME (type) != NULL)
7126 return TYPE_NAME (type);
7127 else
7128 return TYPE_TAG_NAME (type);
7129}
7130
b4ba55a1
JB
7131/* Search the list of "descriptive" types associated to TYPE for a type
7132 whose name is NAME. */
7133
7134static struct type *
7135find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7136{
7137 struct type *result;
7138
7139 /* If there no descriptive-type info, then there is no parallel type
7140 to be found. */
7141 if (!HAVE_GNAT_AUX_INFO (type))
7142 return NULL;
7143
7144 result = TYPE_DESCRIPTIVE_TYPE (type);
7145 while (result != NULL)
7146 {
0d5cff50 7147 const char *result_name = ada_type_name (result);
b4ba55a1
JB
7148
7149 if (result_name == NULL)
7150 {
7151 warning (_("unexpected null name on descriptive type"));
7152 return NULL;
7153 }
7154
7155 /* If the names match, stop. */
7156 if (strcmp (result_name, name) == 0)
7157 break;
7158
7159 /* Otherwise, look at the next item on the list, if any. */
7160 if (HAVE_GNAT_AUX_INFO (result))
7161 result = TYPE_DESCRIPTIVE_TYPE (result);
7162 else
7163 result = NULL;
7164 }
7165
7166 /* If we didn't find a match, see whether this is a packed array. With
7167 older compilers, the descriptive type information is either absent or
7168 irrelevant when it comes to packed arrays so the above lookup fails.
7169 Fall back to using a parallel lookup by name in this case. */
12ab9e09 7170 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
7171 return ada_find_any_type (name);
7172
7173 return result;
7174}
7175
7176/* Find a parallel type to TYPE with the specified NAME, using the
7177 descriptive type taken from the debugging information, if available,
7178 and otherwise using the (slower) name-based method. */
7179
7180static struct type *
7181ada_find_parallel_type_with_name (struct type *type, const char *name)
7182{
7183 struct type *result = NULL;
7184
7185 if (HAVE_GNAT_AUX_INFO (type))
7186 result = find_parallel_type_by_descriptive_type (type, name);
7187 else
7188 result = ada_find_any_type (name);
7189
7190 return result;
7191}
7192
7193/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 7194 SUFFIX to the name of TYPE. */
14f9c5c9 7195
d2e4a39e 7196struct type *
ebf56fd3 7197ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 7198{
0d5cff50
DE
7199 char *name;
7200 const char *typename = ada_type_name (type);
14f9c5c9 7201 int len;
d2e4a39e 7202
14f9c5c9
AS
7203 if (typename == NULL)
7204 return NULL;
7205
7206 len = strlen (typename);
7207
b4ba55a1 7208 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9
AS
7209
7210 strcpy (name, typename);
7211 strcpy (name + len, suffix);
7212
b4ba55a1 7213 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
7214}
7215
14f9c5c9 7216/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 7217 type describing its fields. Otherwise, return NULL. */
14f9c5c9 7218
d2e4a39e
AS
7219static struct type *
7220dynamic_template_type (struct type *type)
14f9c5c9 7221{
61ee279c 7222 type = ada_check_typedef (type);
14f9c5c9
AS
7223
7224 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 7225 || ada_type_name (type) == NULL)
14f9c5c9 7226 return NULL;
d2e4a39e 7227 else
14f9c5c9
AS
7228 {
7229 int len = strlen (ada_type_name (type));
5b4ee69b 7230
4c4b4cd2
PH
7231 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7232 return type;
14f9c5c9 7233 else
4c4b4cd2 7234 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
7235 }
7236}
7237
7238/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 7239 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 7240
d2e4a39e
AS
7241static int
7242is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
7243{
7244 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 7245
d2e4a39e 7246 return name != NULL
14f9c5c9
AS
7247 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
7248 && strstr (name, "___XVL") != NULL;
7249}
7250
4c4b4cd2
PH
7251/* The index of the variant field of TYPE, or -1 if TYPE does not
7252 represent a variant record type. */
14f9c5c9 7253
d2e4a39e 7254static int
4c4b4cd2 7255variant_field_index (struct type *type)
14f9c5c9
AS
7256{
7257 int f;
7258
4c4b4cd2
PH
7259 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
7260 return -1;
7261
7262 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
7263 {
7264 if (ada_is_variant_part (type, f))
7265 return f;
7266 }
7267 return -1;
14f9c5c9
AS
7268}
7269
4c4b4cd2
PH
7270/* A record type with no fields. */
7271
d2e4a39e 7272static struct type *
e9bb382b 7273empty_record (struct type *template)
14f9c5c9 7274{
e9bb382b 7275 struct type *type = alloc_type_copy (template);
5b4ee69b 7276
14f9c5c9
AS
7277 TYPE_CODE (type) = TYPE_CODE_STRUCT;
7278 TYPE_NFIELDS (type) = 0;
7279 TYPE_FIELDS (type) = NULL;
b1f33ddd 7280 INIT_CPLUS_SPECIFIC (type);
14f9c5c9
AS
7281 TYPE_NAME (type) = "<empty>";
7282 TYPE_TAG_NAME (type) = NULL;
14f9c5c9
AS
7283 TYPE_LENGTH (type) = 0;
7284 return type;
7285}
7286
7287/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
7288 the value of type TYPE at VALADDR or ADDRESS (see comments at
7289 the beginning of this section) VAL according to GNAT conventions.
7290 DVAL0 should describe the (portion of a) record that contains any
df407dfe 7291 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
7292 an outer-level type (i.e., as opposed to a branch of a variant.) A
7293 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 7294 of the variant.
14f9c5c9 7295
4c4b4cd2
PH
7296 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7297 length are not statically known are discarded. As a consequence,
7298 VALADDR, ADDRESS and DVAL0 are ignored.
7299
7300 NOTE: Limitations: For now, we assume that dynamic fields and
7301 variants occupy whole numbers of bytes. However, they need not be
7302 byte-aligned. */
7303
7304struct type *
10a2c479 7305ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 7306 const gdb_byte *valaddr,
4c4b4cd2
PH
7307 CORE_ADDR address, struct value *dval0,
7308 int keep_dynamic_fields)
14f9c5c9 7309{
d2e4a39e
AS
7310 struct value *mark = value_mark ();
7311 struct value *dval;
7312 struct type *rtype;
14f9c5c9 7313 int nfields, bit_len;
4c4b4cd2 7314 int variant_field;
14f9c5c9 7315 long off;
d94e4f4f 7316 int fld_bit_len;
14f9c5c9
AS
7317 int f;
7318
4c4b4cd2
PH
7319 /* Compute the number of fields in this record type that are going
7320 to be processed: unless keep_dynamic_fields, this includes only
7321 fields whose position and length are static will be processed. */
7322 if (keep_dynamic_fields)
7323 nfields = TYPE_NFIELDS (type);
7324 else
7325 {
7326 nfields = 0;
76a01679 7327 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
7328 && !ada_is_variant_part (type, nfields)
7329 && !is_dynamic_field (type, nfields))
7330 nfields++;
7331 }
7332
e9bb382b 7333 rtype = alloc_type_copy (type);
14f9c5c9
AS
7334 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7335 INIT_CPLUS_SPECIFIC (rtype);
7336 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 7337 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
7338 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7339 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
7340 TYPE_NAME (rtype) = ada_type_name (type);
7341 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7342 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 7343
d2e4a39e
AS
7344 off = 0;
7345 bit_len = 0;
4c4b4cd2
PH
7346 variant_field = -1;
7347
14f9c5c9
AS
7348 for (f = 0; f < nfields; f += 1)
7349 {
6c038f32
PH
7350 off = align_value (off, field_alignment (type, f))
7351 + TYPE_FIELD_BITPOS (type, f);
14f9c5c9 7352 TYPE_FIELD_BITPOS (rtype, f) = off;
d2e4a39e 7353 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 7354
d2e4a39e 7355 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
7356 {
7357 variant_field = f;
d94e4f4f 7358 fld_bit_len = 0;
4c4b4cd2 7359 }
14f9c5c9 7360 else if (is_dynamic_field (type, f))
4c4b4cd2 7361 {
284614f0
JB
7362 const gdb_byte *field_valaddr = valaddr;
7363 CORE_ADDR field_address = address;
7364 struct type *field_type =
7365 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
7366
4c4b4cd2 7367 if (dval0 == NULL)
b5304971
JG
7368 {
7369 /* rtype's length is computed based on the run-time
7370 value of discriminants. If the discriminants are not
7371 initialized, the type size may be completely bogus and
0963b4bd 7372 GDB may fail to allocate a value for it. So check the
b5304971
JG
7373 size first before creating the value. */
7374 check_size (rtype);
7375 dval = value_from_contents_and_address (rtype, valaddr, address);
7376 }
4c4b4cd2
PH
7377 else
7378 dval = dval0;
7379
284614f0
JB
7380 /* If the type referenced by this field is an aligner type, we need
7381 to unwrap that aligner type, because its size might not be set.
7382 Keeping the aligner type would cause us to compute the wrong
7383 size for this field, impacting the offset of the all the fields
7384 that follow this one. */
7385 if (ada_is_aligner_type (field_type))
7386 {
7387 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
7388
7389 field_valaddr = cond_offset_host (field_valaddr, field_offset);
7390 field_address = cond_offset_target (field_address, field_offset);
7391 field_type = ada_aligned_type (field_type);
7392 }
7393
7394 field_valaddr = cond_offset_host (field_valaddr,
7395 off / TARGET_CHAR_BIT);
7396 field_address = cond_offset_target (field_address,
7397 off / TARGET_CHAR_BIT);
7398
7399 /* Get the fixed type of the field. Note that, in this case,
7400 we do not want to get the real type out of the tag: if
7401 the current field is the parent part of a tagged record,
7402 we will get the tag of the object. Clearly wrong: the real
7403 type of the parent is not the real type of the child. We
7404 would end up in an infinite loop. */
7405 field_type = ada_get_base_type (field_type);
7406 field_type = ada_to_fixed_type (field_type, field_valaddr,
7407 field_address, dval, 0);
27f2a97b
JB
7408 /* If the field size is already larger than the maximum
7409 object size, then the record itself will necessarily
7410 be larger than the maximum object size. We need to make
7411 this check now, because the size might be so ridiculously
7412 large (due to an uninitialized variable in the inferior)
7413 that it would cause an overflow when adding it to the
7414 record size. */
7415 check_size (field_type);
284614f0
JB
7416
7417 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 7418 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
7419 /* The multiplication can potentially overflow. But because
7420 the field length has been size-checked just above, and
7421 assuming that the maximum size is a reasonable value,
7422 an overflow should not happen in practice. So rather than
7423 adding overflow recovery code to this already complex code,
7424 we just assume that it's not going to happen. */
d94e4f4f 7425 fld_bit_len =
4c4b4cd2
PH
7426 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
7427 }
14f9c5c9 7428 else
4c4b4cd2 7429 {
9f0dec2d
JB
7430 struct type *field_type = TYPE_FIELD_TYPE (type, f);
7431
720d1a40
JB
7432 /* If our field is a typedef type (most likely a typedef of
7433 a fat pointer, encoding an array access), then we need to
7434 look at its target type to determine its characteristics.
7435 In particular, we would miscompute the field size if we took
7436 the size of the typedef (zero), instead of the size of
7437 the target type. */
7438 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
7439 field_type = ada_typedef_target_type (field_type);
7440
9f0dec2d 7441 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2
PH
7442 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7443 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 7444 fld_bit_len =
4c4b4cd2
PH
7445 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7446 else
d94e4f4f 7447 fld_bit_len =
9f0dec2d 7448 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
4c4b4cd2 7449 }
14f9c5c9 7450 if (off + fld_bit_len > bit_len)
4c4b4cd2 7451 bit_len = off + fld_bit_len;
d94e4f4f 7452 off += fld_bit_len;
4c4b4cd2
PH
7453 TYPE_LENGTH (rtype) =
7454 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 7455 }
4c4b4cd2
PH
7456
7457 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 7458 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
7459 the record. This can happen in the presence of representation
7460 clauses. */
7461 if (variant_field >= 0)
7462 {
7463 struct type *branch_type;
7464
7465 off = TYPE_FIELD_BITPOS (rtype, variant_field);
7466
7467 if (dval0 == NULL)
7468 dval = value_from_contents_and_address (rtype, valaddr, address);
7469 else
7470 dval = dval0;
7471
7472 branch_type =
7473 to_fixed_variant_branch_type
7474 (TYPE_FIELD_TYPE (type, variant_field),
7475 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7476 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7477 if (branch_type == NULL)
7478 {
7479 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
7480 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7481 TYPE_NFIELDS (rtype) -= 1;
7482 }
7483 else
7484 {
7485 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7486 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7487 fld_bit_len =
7488 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
7489 TARGET_CHAR_BIT;
7490 if (off + fld_bit_len > bit_len)
7491 bit_len = off + fld_bit_len;
7492 TYPE_LENGTH (rtype) =
7493 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7494 }
7495 }
7496
714e53ab
PH
7497 /* According to exp_dbug.ads, the size of TYPE for variable-size records
7498 should contain the alignment of that record, which should be a strictly
7499 positive value. If null or negative, then something is wrong, most
7500 probably in the debug info. In that case, we don't round up the size
0963b4bd 7501 of the resulting type. If this record is not part of another structure,
714e53ab
PH
7502 the current RTYPE length might be good enough for our purposes. */
7503 if (TYPE_LENGTH (type) <= 0)
7504 {
323e0a4a
AC
7505 if (TYPE_NAME (rtype))
7506 warning (_("Invalid type size for `%s' detected: %d."),
7507 TYPE_NAME (rtype), TYPE_LENGTH (type));
7508 else
7509 warning (_("Invalid type size for <unnamed> detected: %d."),
7510 TYPE_LENGTH (type));
714e53ab
PH
7511 }
7512 else
7513 {
7514 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
7515 TYPE_LENGTH (type));
7516 }
14f9c5c9
AS
7517
7518 value_free_to_mark (mark);
d2e4a39e 7519 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 7520 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
7521 return rtype;
7522}
7523
4c4b4cd2
PH
7524/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7525 of 1. */
14f9c5c9 7526
d2e4a39e 7527static struct type *
fc1a4b47 7528template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
7529 CORE_ADDR address, struct value *dval0)
7530{
7531 return ada_template_to_fixed_record_type_1 (type, valaddr,
7532 address, dval0, 1);
7533}
7534
7535/* An ordinary record type in which ___XVL-convention fields and
7536 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7537 static approximations, containing all possible fields. Uses
7538 no runtime values. Useless for use in values, but that's OK,
7539 since the results are used only for type determinations. Works on both
7540 structs and unions. Representation note: to save space, we memorize
7541 the result of this function in the TYPE_TARGET_TYPE of the
7542 template type. */
7543
7544static struct type *
7545template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
7546{
7547 struct type *type;
7548 int nfields;
7549 int f;
7550
4c4b4cd2
PH
7551 if (TYPE_TARGET_TYPE (type0) != NULL)
7552 return TYPE_TARGET_TYPE (type0);
7553
7554 nfields = TYPE_NFIELDS (type0);
7555 type = type0;
14f9c5c9
AS
7556
7557 for (f = 0; f < nfields; f += 1)
7558 {
61ee279c 7559 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
4c4b4cd2 7560 struct type *new_type;
14f9c5c9 7561
4c4b4cd2
PH
7562 if (is_dynamic_field (type0, f))
7563 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
14f9c5c9 7564 else
f192137b 7565 new_type = static_unwrap_type (field_type);
4c4b4cd2
PH
7566 if (type == type0 && new_type != field_type)
7567 {
e9bb382b 7568 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
4c4b4cd2
PH
7569 TYPE_CODE (type) = TYPE_CODE (type0);
7570 INIT_CPLUS_SPECIFIC (type);
7571 TYPE_NFIELDS (type) = nfields;
7572 TYPE_FIELDS (type) = (struct field *)
7573 TYPE_ALLOC (type, nfields * sizeof (struct field));
7574 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
7575 sizeof (struct field) * nfields);
7576 TYPE_NAME (type) = ada_type_name (type0);
7577 TYPE_TAG_NAME (type) = NULL;
876cecd0 7578 TYPE_FIXED_INSTANCE (type) = 1;
4c4b4cd2
PH
7579 TYPE_LENGTH (type) = 0;
7580 }
7581 TYPE_FIELD_TYPE (type, f) = new_type;
7582 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
14f9c5c9 7583 }
14f9c5c9
AS
7584 return type;
7585}
7586
4c4b4cd2 7587/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
7588 whose address in memory is ADDRESS, returns a revision of TYPE,
7589 which should be a non-dynamic-sized record, in which the variant
7590 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
7591 for discriminant values in DVAL0, which can be NULL if the record
7592 contains the necessary discriminant values. */
7593
d2e4a39e 7594static struct type *
fc1a4b47 7595to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 7596 CORE_ADDR address, struct value *dval0)
14f9c5c9 7597{
d2e4a39e 7598 struct value *mark = value_mark ();
4c4b4cd2 7599 struct value *dval;
d2e4a39e 7600 struct type *rtype;
14f9c5c9
AS
7601 struct type *branch_type;
7602 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 7603 int variant_field = variant_field_index (type);
14f9c5c9 7604
4c4b4cd2 7605 if (variant_field == -1)
14f9c5c9
AS
7606 return type;
7607
4c4b4cd2
PH
7608 if (dval0 == NULL)
7609 dval = value_from_contents_and_address (type, valaddr, address);
7610 else
7611 dval = dval0;
7612
e9bb382b 7613 rtype = alloc_type_copy (type);
14f9c5c9 7614 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
7615 INIT_CPLUS_SPECIFIC (rtype);
7616 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
7617 TYPE_FIELDS (rtype) =
7618 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7619 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 7620 sizeof (struct field) * nfields);
14f9c5c9
AS
7621 TYPE_NAME (rtype) = ada_type_name (type);
7622 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7623 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
7624 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7625
4c4b4cd2
PH
7626 branch_type = to_fixed_variant_branch_type
7627 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 7628 cond_offset_host (valaddr,
4c4b4cd2
PH
7629 TYPE_FIELD_BITPOS (type, variant_field)
7630 / TARGET_CHAR_BIT),
d2e4a39e 7631 cond_offset_target (address,
4c4b4cd2
PH
7632 TYPE_FIELD_BITPOS (type, variant_field)
7633 / TARGET_CHAR_BIT), dval);
d2e4a39e 7634 if (branch_type == NULL)
14f9c5c9 7635 {
4c4b4cd2 7636 int f;
5b4ee69b 7637
4c4b4cd2
PH
7638 for (f = variant_field + 1; f < nfields; f += 1)
7639 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 7640 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
7641 }
7642 else
7643 {
4c4b4cd2
PH
7644 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7645 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7646 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 7647 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 7648 }
4c4b4cd2 7649 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 7650
4c4b4cd2 7651 value_free_to_mark (mark);
14f9c5c9
AS
7652 return rtype;
7653}
7654
7655/* An ordinary record type (with fixed-length fields) that describes
7656 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7657 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
7658 should be in DVAL, a record value; it may be NULL if the object
7659 at ADDR itself contains any necessary discriminant values.
7660 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7661 values from the record are needed. Except in the case that DVAL,
7662 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7663 unchecked) is replaced by a particular branch of the variant.
7664
7665 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7666 is questionable and may be removed. It can arise during the
7667 processing of an unconstrained-array-of-record type where all the
7668 variant branches have exactly the same size. This is because in
7669 such cases, the compiler does not bother to use the XVS convention
7670 when encoding the record. I am currently dubious of this
7671 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 7672
d2e4a39e 7673static struct type *
fc1a4b47 7674to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 7675 CORE_ADDR address, struct value *dval)
14f9c5c9 7676{
d2e4a39e 7677 struct type *templ_type;
14f9c5c9 7678
876cecd0 7679 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
7680 return type0;
7681
d2e4a39e 7682 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
7683
7684 if (templ_type != NULL)
7685 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
7686 else if (variant_field_index (type0) >= 0)
7687 {
7688 if (dval == NULL && valaddr == NULL && address == 0)
7689 return type0;
7690 return to_record_with_fixed_variant_part (type0, valaddr, address,
7691 dval);
7692 }
14f9c5c9
AS
7693 else
7694 {
876cecd0 7695 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
7696 return type0;
7697 }
7698
7699}
7700
7701/* An ordinary record type (with fixed-length fields) that describes
7702 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7703 union type. Any necessary discriminants' values should be in DVAL,
7704 a record value. That is, this routine selects the appropriate
7705 branch of the union at ADDR according to the discriminant value
b1f33ddd 7706 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 7707 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 7708
d2e4a39e 7709static struct type *
fc1a4b47 7710to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 7711 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
7712{
7713 int which;
d2e4a39e
AS
7714 struct type *templ_type;
7715 struct type *var_type;
14f9c5c9
AS
7716
7717 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
7718 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 7719 else
14f9c5c9
AS
7720 var_type = var_type0;
7721
7722 templ_type = ada_find_parallel_type (var_type, "___XVU");
7723
7724 if (templ_type != NULL)
7725 var_type = templ_type;
7726
b1f33ddd
JB
7727 if (is_unchecked_variant (var_type, value_type (dval)))
7728 return var_type0;
d2e4a39e
AS
7729 which =
7730 ada_which_variant_applies (var_type,
0fd88904 7731 value_type (dval), value_contents (dval));
14f9c5c9
AS
7732
7733 if (which < 0)
e9bb382b 7734 return empty_record (var_type);
14f9c5c9 7735 else if (is_dynamic_field (var_type, which))
4c4b4cd2 7736 return to_fixed_record_type
d2e4a39e
AS
7737 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
7738 valaddr, address, dval);
4c4b4cd2 7739 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
7740 return
7741 to_fixed_record_type
7742 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
7743 else
7744 return TYPE_FIELD_TYPE (var_type, which);
7745}
7746
7747/* Assuming that TYPE0 is an array type describing the type of a value
7748 at ADDR, and that DVAL describes a record containing any
7749 discriminants used in TYPE0, returns a type for the value that
7750 contains no dynamic components (that is, no components whose sizes
7751 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7752 true, gives an error message if the resulting type's size is over
4c4b4cd2 7753 varsize_limit. */
14f9c5c9 7754
d2e4a39e
AS
7755static struct type *
7756to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 7757 int ignore_too_big)
14f9c5c9 7758{
d2e4a39e
AS
7759 struct type *index_type_desc;
7760 struct type *result;
ad82864c 7761 int constrained_packed_array_p;
14f9c5c9 7762
b0dd7688 7763 type0 = ada_check_typedef (type0);
284614f0 7764 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 7765 return type0;
14f9c5c9 7766
ad82864c
JB
7767 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
7768 if (constrained_packed_array_p)
7769 type0 = decode_constrained_packed_array_type (type0);
284614f0 7770
14f9c5c9 7771 index_type_desc = ada_find_parallel_type (type0, "___XA");
28c85d6c 7772 ada_fixup_array_indexes_type (index_type_desc);
14f9c5c9
AS
7773 if (index_type_desc == NULL)
7774 {
61ee279c 7775 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 7776
14f9c5c9 7777 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
7778 depend on the contents of the array in properly constructed
7779 debugging data. */
529cad9c
PH
7780 /* Create a fixed version of the array element type.
7781 We're not providing the address of an element here,
e1d5a0d2 7782 and thus the actual object value cannot be inspected to do
529cad9c
PH
7783 the conversion. This should not be a problem, since arrays of
7784 unconstrained objects are not allowed. In particular, all
7785 the elements of an array of a tagged type should all be of
7786 the same type specified in the debugging info. No need to
7787 consult the object tag. */
1ed6ede0 7788 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 7789
284614f0
JB
7790 /* Make sure we always create a new array type when dealing with
7791 packed array types, since we're going to fix-up the array
7792 type length and element bitsize a little further down. */
ad82864c 7793 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 7794 result = type0;
14f9c5c9 7795 else
e9bb382b 7796 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 7797 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
7798 }
7799 else
7800 {
7801 int i;
7802 struct type *elt_type0;
7803
7804 elt_type0 = type0;
7805 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 7806 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
7807
7808 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
7809 depend on the contents of the array in properly constructed
7810 debugging data. */
529cad9c
PH
7811 /* Create a fixed version of the array element type.
7812 We're not providing the address of an element here,
e1d5a0d2 7813 and thus the actual object value cannot be inspected to do
529cad9c
PH
7814 the conversion. This should not be a problem, since arrays of
7815 unconstrained objects are not allowed. In particular, all
7816 the elements of an array of a tagged type should all be of
7817 the same type specified in the debugging info. No need to
7818 consult the object tag. */
1ed6ede0
JB
7819 result =
7820 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
7821
7822 elt_type0 = type0;
14f9c5c9 7823 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
7824 {
7825 struct type *range_type =
28c85d6c 7826 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 7827
e9bb382b 7828 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 7829 result, range_type);
1ce677a4 7830 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 7831 }
d2e4a39e 7832 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 7833 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
7834 }
7835
2e6fda7d
JB
7836 /* We want to preserve the type name. This can be useful when
7837 trying to get the type name of a value that has already been
7838 printed (for instance, if the user did "print VAR; whatis $". */
7839 TYPE_NAME (result) = TYPE_NAME (type0);
7840
ad82864c 7841 if (constrained_packed_array_p)
284614f0
JB
7842 {
7843 /* So far, the resulting type has been created as if the original
7844 type was a regular (non-packed) array type. As a result, the
7845 bitsize of the array elements needs to be set again, and the array
7846 length needs to be recomputed based on that bitsize. */
7847 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
7848 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
7849
7850 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
7851 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
7852 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
7853 TYPE_LENGTH (result)++;
7854 }
7855
876cecd0 7856 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 7857 return result;
d2e4a39e 7858}
14f9c5c9
AS
7859
7860
7861/* A standard type (containing no dynamically sized components)
7862 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7863 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 7864 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
7865 ADDRESS or in VALADDR contains these discriminants.
7866
1ed6ede0
JB
7867 If CHECK_TAG is not null, in the case of tagged types, this function
7868 attempts to locate the object's tag and use it to compute the actual
7869 type. However, when ADDRESS is null, we cannot use it to determine the
7870 location of the tag, and therefore compute the tagged type's actual type.
7871 So we return the tagged type without consulting the tag. */
529cad9c 7872
f192137b
JB
7873static struct type *
7874ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 7875 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 7876{
61ee279c 7877 type = ada_check_typedef (type);
d2e4a39e
AS
7878 switch (TYPE_CODE (type))
7879 {
7880 default:
14f9c5c9 7881 return type;
d2e4a39e 7882 case TYPE_CODE_STRUCT:
4c4b4cd2 7883 {
76a01679 7884 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
7885 struct type *fixed_record_type =
7886 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 7887
529cad9c
PH
7888 /* If STATIC_TYPE is a tagged type and we know the object's address,
7889 then we can determine its tag, and compute the object's actual
0963b4bd 7890 type from there. Note that we have to use the fixed record
1ed6ede0
JB
7891 type (the parent part of the record may have dynamic fields
7892 and the way the location of _tag is expressed may depend on
7893 them). */
529cad9c 7894
1ed6ede0 7895 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679
JB
7896 {
7897 struct type *real_type =
1ed6ede0
JB
7898 type_from_tag (value_tag_from_contents_and_address
7899 (fixed_record_type,
7900 valaddr,
7901 address));
5b4ee69b 7902
76a01679 7903 if (real_type != NULL)
1ed6ede0 7904 return to_fixed_record_type (real_type, valaddr, address, NULL);
76a01679 7905 }
4af88198
JB
7906
7907 /* Check to see if there is a parallel ___XVZ variable.
7908 If there is, then it provides the actual size of our type. */
7909 else if (ada_type_name (fixed_record_type) != NULL)
7910 {
0d5cff50 7911 const char *name = ada_type_name (fixed_record_type);
4af88198
JB
7912 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
7913 int xvz_found = 0;
7914 LONGEST size;
7915
88c15c34 7916 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
4af88198
JB
7917 size = get_int_var_value (xvz_name, &xvz_found);
7918 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
7919 {
7920 fixed_record_type = copy_type (fixed_record_type);
7921 TYPE_LENGTH (fixed_record_type) = size;
7922
7923 /* The FIXED_RECORD_TYPE may have be a stub. We have
7924 observed this when the debugging info is STABS, and
7925 apparently it is something that is hard to fix.
7926
7927 In practice, we don't need the actual type definition
7928 at all, because the presence of the XVZ variable allows us
7929 to assume that there must be a XVS type as well, which we
7930 should be able to use later, when we need the actual type
7931 definition.
7932
7933 In the meantime, pretend that the "fixed" type we are
7934 returning is NOT a stub, because this can cause trouble
7935 when using this type to create new types targeting it.
7936 Indeed, the associated creation routines often check
7937 whether the target type is a stub and will try to replace
0963b4bd 7938 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
7939 might cause the new type to have the wrong size too.
7940 Consider the case of an array, for instance, where the size
7941 of the array is computed from the number of elements in
7942 our array multiplied by the size of its element. */
7943 TYPE_STUB (fixed_record_type) = 0;
7944 }
7945 }
1ed6ede0 7946 return fixed_record_type;
4c4b4cd2 7947 }
d2e4a39e 7948 case TYPE_CODE_ARRAY:
4c4b4cd2 7949 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
7950 case TYPE_CODE_UNION:
7951 if (dval == NULL)
4c4b4cd2 7952 return type;
d2e4a39e 7953 else
4c4b4cd2 7954 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 7955 }
14f9c5c9
AS
7956}
7957
f192137b
JB
7958/* The same as ada_to_fixed_type_1, except that it preserves the type
7959 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
7960
7961 The typedef layer needs be preserved in order to differentiate between
7962 arrays and array pointers when both types are implemented using the same
7963 fat pointer. In the array pointer case, the pointer is encoded as
7964 a typedef of the pointer type. For instance, considering:
7965
7966 type String_Access is access String;
7967 S1 : String_Access := null;
7968
7969 To the debugger, S1 is defined as a typedef of type String. But
7970 to the user, it is a pointer. So if the user tries to print S1,
7971 we should not dereference the array, but print the array address
7972 instead.
7973
7974 If we didn't preserve the typedef layer, we would lose the fact that
7975 the type is to be presented as a pointer (needs de-reference before
7976 being printed). And we would also use the source-level type name. */
f192137b
JB
7977
7978struct type *
7979ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
7980 CORE_ADDR address, struct value *dval, int check_tag)
7981
7982{
7983 struct type *fixed_type =
7984 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
7985
96dbd2c1
JB
7986 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
7987 then preserve the typedef layer.
7988
7989 Implementation note: We can only check the main-type portion of
7990 the TYPE and FIXED_TYPE, because eliminating the typedef layer
7991 from TYPE now returns a type that has the same instance flags
7992 as TYPE. For instance, if TYPE is a "typedef const", and its
7993 target type is a "struct", then the typedef elimination will return
7994 a "const" version of the target type. See check_typedef for more
7995 details about how the typedef layer elimination is done.
7996
7997 brobecker/2010-11-19: It seems to me that the only case where it is
7998 useful to preserve the typedef layer is when dealing with fat pointers.
7999 Perhaps, we could add a check for that and preserve the typedef layer
8000 only in that situation. But this seems unecessary so far, probably
8001 because we call check_typedef/ada_check_typedef pretty much everywhere.
8002 */
f192137b 8003 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 8004 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 8005 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
8006 return type;
8007
8008 return fixed_type;
8009}
8010
14f9c5c9 8011/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 8012 TYPE0, but based on no runtime data. */
14f9c5c9 8013
d2e4a39e
AS
8014static struct type *
8015to_static_fixed_type (struct type *type0)
14f9c5c9 8016{
d2e4a39e 8017 struct type *type;
14f9c5c9
AS
8018
8019 if (type0 == NULL)
8020 return NULL;
8021
876cecd0 8022 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8023 return type0;
8024
61ee279c 8025 type0 = ada_check_typedef (type0);
d2e4a39e 8026
14f9c5c9
AS
8027 switch (TYPE_CODE (type0))
8028 {
8029 default:
8030 return type0;
8031 case TYPE_CODE_STRUCT:
8032 type = dynamic_template_type (type0);
d2e4a39e 8033 if (type != NULL)
4c4b4cd2
PH
8034 return template_to_static_fixed_type (type);
8035 else
8036 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8037 case TYPE_CODE_UNION:
8038 type = ada_find_parallel_type (type0, "___XVU");
8039 if (type != NULL)
4c4b4cd2
PH
8040 return template_to_static_fixed_type (type);
8041 else
8042 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8043 }
8044}
8045
4c4b4cd2
PH
8046/* A static approximation of TYPE with all type wrappers removed. */
8047
d2e4a39e
AS
8048static struct type *
8049static_unwrap_type (struct type *type)
14f9c5c9
AS
8050{
8051 if (ada_is_aligner_type (type))
8052 {
61ee279c 8053 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 8054 if (ada_type_name (type1) == NULL)
4c4b4cd2 8055 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
8056
8057 return static_unwrap_type (type1);
8058 }
d2e4a39e 8059 else
14f9c5c9 8060 {
d2e4a39e 8061 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 8062
d2e4a39e 8063 if (raw_real_type == type)
4c4b4cd2 8064 return type;
14f9c5c9 8065 else
4c4b4cd2 8066 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
8067 }
8068}
8069
8070/* In some cases, incomplete and private types require
4c4b4cd2 8071 cross-references that are not resolved as records (for example,
14f9c5c9
AS
8072 type Foo;
8073 type FooP is access Foo;
8074 V: FooP;
8075 type Foo is array ...;
4c4b4cd2 8076 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
8077 cross-references to such types, we instead substitute for FooP a
8078 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 8079 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
8080
8081/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
8082 exists, otherwise TYPE. */
8083
d2e4a39e 8084struct type *
61ee279c 8085ada_check_typedef (struct type *type)
14f9c5c9 8086{
727e3d2e
JB
8087 if (type == NULL)
8088 return NULL;
8089
720d1a40
JB
8090 /* If our type is a typedef type of a fat pointer, then we're done.
8091 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8092 what allows us to distinguish between fat pointers that represent
8093 array types, and fat pointers that represent array access types
8094 (in both cases, the compiler implements them as fat pointers). */
8095 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8096 && is_thick_pntr (ada_typedef_target_type (type)))
8097 return type;
8098
14f9c5c9
AS
8099 CHECK_TYPEDEF (type);
8100 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 8101 || !TYPE_STUB (type)
14f9c5c9
AS
8102 || TYPE_TAG_NAME (type) == NULL)
8103 return type;
d2e4a39e 8104 else
14f9c5c9 8105 {
0d5cff50 8106 const char *name = TYPE_TAG_NAME (type);
d2e4a39e 8107 struct type *type1 = ada_find_any_type (name);
5b4ee69b 8108
05e522ef
JB
8109 if (type1 == NULL)
8110 return type;
8111
8112 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8113 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
8114 types, only for the typedef-to-array types). If that's the case,
8115 strip the typedef layer. */
8116 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
8117 type1 = ada_check_typedef (type1);
8118
8119 return type1;
14f9c5c9
AS
8120 }
8121}
8122
8123/* A value representing the data at VALADDR/ADDRESS as described by
8124 type TYPE0, but with a standard (static-sized) type that correctly
8125 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8126 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 8127 creation of struct values]. */
14f9c5c9 8128
4c4b4cd2
PH
8129static struct value *
8130ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8131 struct value *val0)
14f9c5c9 8132{
1ed6ede0 8133 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 8134
14f9c5c9
AS
8135 if (type == type0 && val0 != NULL)
8136 return val0;
d2e4a39e 8137 else
4c4b4cd2
PH
8138 return value_from_contents_and_address (type, 0, address);
8139}
8140
8141/* A value representing VAL, but with a standard (static-sized) type
8142 that correctly describes it. Does not necessarily create a new
8143 value. */
8144
0c3acc09 8145struct value *
4c4b4cd2
PH
8146ada_to_fixed_value (struct value *val)
8147{
c48db5ca
JB
8148 val = unwrap_value (val);
8149 val = ada_to_fixed_value_create (value_type (val),
8150 value_address (val),
8151 val);
8152 return val;
14f9c5c9 8153}
d2e4a39e 8154\f
14f9c5c9 8155
14f9c5c9
AS
8156/* Attributes */
8157
4c4b4cd2
PH
8158/* Table mapping attribute numbers to names.
8159 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 8160
d2e4a39e 8161static const char *attribute_names[] = {
14f9c5c9
AS
8162 "<?>",
8163
d2e4a39e 8164 "first",
14f9c5c9
AS
8165 "last",
8166 "length",
8167 "image",
14f9c5c9
AS
8168 "max",
8169 "min",
4c4b4cd2
PH
8170 "modulus",
8171 "pos",
8172 "size",
8173 "tag",
14f9c5c9 8174 "val",
14f9c5c9
AS
8175 0
8176};
8177
d2e4a39e 8178const char *
4c4b4cd2 8179ada_attribute_name (enum exp_opcode n)
14f9c5c9 8180{
4c4b4cd2
PH
8181 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8182 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
8183 else
8184 return attribute_names[0];
8185}
8186
4c4b4cd2 8187/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 8188
4c4b4cd2
PH
8189static LONGEST
8190pos_atr (struct value *arg)
14f9c5c9 8191{
24209737
PH
8192 struct value *val = coerce_ref (arg);
8193 struct type *type = value_type (val);
14f9c5c9 8194
d2e4a39e 8195 if (!discrete_type_p (type))
323e0a4a 8196 error (_("'POS only defined on discrete types"));
14f9c5c9
AS
8197
8198 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8199 {
8200 int i;
24209737 8201 LONGEST v = value_as_long (val);
14f9c5c9 8202
d2e4a39e 8203 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
8204 {
8205 if (v == TYPE_FIELD_BITPOS (type, i))
8206 return i;
8207 }
323e0a4a 8208 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9
AS
8209 }
8210 else
24209737 8211 return value_as_long (val);
4c4b4cd2
PH
8212}
8213
8214static struct value *
3cb382c9 8215value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 8216{
3cb382c9 8217 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
8218}
8219
4c4b4cd2 8220/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 8221
d2e4a39e
AS
8222static struct value *
8223value_val_atr (struct type *type, struct value *arg)
14f9c5c9 8224{
d2e4a39e 8225 if (!discrete_type_p (type))
323e0a4a 8226 error (_("'VAL only defined on discrete types"));
df407dfe 8227 if (!integer_type_p (value_type (arg)))
323e0a4a 8228 error (_("'VAL requires integral argument"));
14f9c5c9
AS
8229
8230 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8231 {
8232 long pos = value_as_long (arg);
5b4ee69b 8233
14f9c5c9 8234 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 8235 error (_("argument to 'VAL out of range"));
d2e4a39e 8236 return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
14f9c5c9
AS
8237 }
8238 else
8239 return value_from_longest (type, value_as_long (arg));
8240}
14f9c5c9 8241\f
d2e4a39e 8242
4c4b4cd2 8243 /* Evaluation */
14f9c5c9 8244
4c4b4cd2
PH
8245/* True if TYPE appears to be an Ada character type.
8246 [At the moment, this is true only for Character and Wide_Character;
8247 It is a heuristic test that could stand improvement]. */
14f9c5c9 8248
d2e4a39e
AS
8249int
8250ada_is_character_type (struct type *type)
14f9c5c9 8251{
7b9f71f2
JB
8252 const char *name;
8253
8254 /* If the type code says it's a character, then assume it really is,
8255 and don't check any further. */
8256 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
8257 return 1;
8258
8259 /* Otherwise, assume it's a character type iff it is a discrete type
8260 with a known character type name. */
8261 name = ada_type_name (type);
8262 return (name != NULL
8263 && (TYPE_CODE (type) == TYPE_CODE_INT
8264 || TYPE_CODE (type) == TYPE_CODE_RANGE)
8265 && (strcmp (name, "character") == 0
8266 || strcmp (name, "wide_character") == 0
5a517ebd 8267 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 8268 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
8269}
8270
4c4b4cd2 8271/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
8272
8273int
ebf56fd3 8274ada_is_string_type (struct type *type)
14f9c5c9 8275{
61ee279c 8276 type = ada_check_typedef (type);
d2e4a39e 8277 if (type != NULL
14f9c5c9 8278 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
8279 && (ada_is_simple_array_type (type)
8280 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
8281 && ada_array_arity (type) == 1)
8282 {
8283 struct type *elttype = ada_array_element_type (type, 1);
8284
8285 return ada_is_character_type (elttype);
8286 }
d2e4a39e 8287 else
14f9c5c9
AS
8288 return 0;
8289}
8290
5bf03f13
JB
8291/* The compiler sometimes provides a parallel XVS type for a given
8292 PAD type. Normally, it is safe to follow the PAD type directly,
8293 but older versions of the compiler have a bug that causes the offset
8294 of its "F" field to be wrong. Following that field in that case
8295 would lead to incorrect results, but this can be worked around
8296 by ignoring the PAD type and using the associated XVS type instead.
8297
8298 Set to True if the debugger should trust the contents of PAD types.
8299 Otherwise, ignore the PAD type if there is a parallel XVS type. */
8300static int trust_pad_over_xvs = 1;
14f9c5c9
AS
8301
8302/* True if TYPE is a struct type introduced by the compiler to force the
8303 alignment of a value. Such types have a single field with a
4c4b4cd2 8304 distinctive name. */
14f9c5c9
AS
8305
8306int
ebf56fd3 8307ada_is_aligner_type (struct type *type)
14f9c5c9 8308{
61ee279c 8309 type = ada_check_typedef (type);
714e53ab 8310
5bf03f13 8311 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
8312 return 0;
8313
14f9c5c9 8314 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
8315 && TYPE_NFIELDS (type) == 1
8316 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
8317}
8318
8319/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 8320 the parallel type. */
14f9c5c9 8321
d2e4a39e
AS
8322struct type *
8323ada_get_base_type (struct type *raw_type)
14f9c5c9 8324{
d2e4a39e
AS
8325 struct type *real_type_namer;
8326 struct type *raw_real_type;
14f9c5c9
AS
8327
8328 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
8329 return raw_type;
8330
284614f0
JB
8331 if (ada_is_aligner_type (raw_type))
8332 /* The encoding specifies that we should always use the aligner type.
8333 So, even if this aligner type has an associated XVS type, we should
8334 simply ignore it.
8335
8336 According to the compiler gurus, an XVS type parallel to an aligner
8337 type may exist because of a stabs limitation. In stabs, aligner
8338 types are empty because the field has a variable-sized type, and
8339 thus cannot actually be used as an aligner type. As a result,
8340 we need the associated parallel XVS type to decode the type.
8341 Since the policy in the compiler is to not change the internal
8342 representation based on the debugging info format, we sometimes
8343 end up having a redundant XVS type parallel to the aligner type. */
8344 return raw_type;
8345
14f9c5c9 8346 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 8347 if (real_type_namer == NULL
14f9c5c9
AS
8348 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
8349 || TYPE_NFIELDS (real_type_namer) != 1)
8350 return raw_type;
8351
f80d3ff2
JB
8352 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
8353 {
8354 /* This is an older encoding form where the base type needs to be
8355 looked up by name. We prefer the newer enconding because it is
8356 more efficient. */
8357 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
8358 if (raw_real_type == NULL)
8359 return raw_type;
8360 else
8361 return raw_real_type;
8362 }
8363
8364 /* The field in our XVS type is a reference to the base type. */
8365 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 8366}
14f9c5c9 8367
4c4b4cd2 8368/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 8369
d2e4a39e
AS
8370struct type *
8371ada_aligned_type (struct type *type)
14f9c5c9
AS
8372{
8373 if (ada_is_aligner_type (type))
8374 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
8375 else
8376 return ada_get_base_type (type);
8377}
8378
8379
8380/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 8381 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 8382
fc1a4b47
AC
8383const gdb_byte *
8384ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 8385{
d2e4a39e 8386 if (ada_is_aligner_type (type))
14f9c5c9 8387 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
8388 valaddr +
8389 TYPE_FIELD_BITPOS (type,
8390 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
8391 else
8392 return valaddr;
8393}
8394
4c4b4cd2
PH
8395
8396
14f9c5c9 8397/* The printed representation of an enumeration literal with encoded
4c4b4cd2 8398 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
8399const char *
8400ada_enum_name (const char *name)
14f9c5c9 8401{
4c4b4cd2
PH
8402 static char *result;
8403 static size_t result_len = 0;
d2e4a39e 8404 char *tmp;
14f9c5c9 8405
4c4b4cd2
PH
8406 /* First, unqualify the enumeration name:
8407 1. Search for the last '.' character. If we find one, then skip
177b42fe 8408 all the preceding characters, the unqualified name starts
76a01679 8409 right after that dot.
4c4b4cd2 8410 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
8411 translates dots into "__". Search forward for double underscores,
8412 but stop searching when we hit an overloading suffix, which is
8413 of the form "__" followed by digits. */
4c4b4cd2 8414
c3e5cd34
PH
8415 tmp = strrchr (name, '.');
8416 if (tmp != NULL)
4c4b4cd2
PH
8417 name = tmp + 1;
8418 else
14f9c5c9 8419 {
4c4b4cd2
PH
8420 while ((tmp = strstr (name, "__")) != NULL)
8421 {
8422 if (isdigit (tmp[2]))
8423 break;
8424 else
8425 name = tmp + 2;
8426 }
14f9c5c9
AS
8427 }
8428
8429 if (name[0] == 'Q')
8430 {
14f9c5c9 8431 int v;
5b4ee69b 8432
14f9c5c9 8433 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
8434 {
8435 if (sscanf (name + 2, "%x", &v) != 1)
8436 return name;
8437 }
14f9c5c9 8438 else
4c4b4cd2 8439 return name;
14f9c5c9 8440
4c4b4cd2 8441 GROW_VECT (result, result_len, 16);
14f9c5c9 8442 if (isascii (v) && isprint (v))
88c15c34 8443 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 8444 else if (name[1] == 'U')
88c15c34 8445 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 8446 else
88c15c34 8447 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
8448
8449 return result;
8450 }
d2e4a39e 8451 else
4c4b4cd2 8452 {
c3e5cd34
PH
8453 tmp = strstr (name, "__");
8454 if (tmp == NULL)
8455 tmp = strstr (name, "$");
8456 if (tmp != NULL)
4c4b4cd2
PH
8457 {
8458 GROW_VECT (result, result_len, tmp - name + 1);
8459 strncpy (result, name, tmp - name);
8460 result[tmp - name] = '\0';
8461 return result;
8462 }
8463
8464 return name;
8465 }
14f9c5c9
AS
8466}
8467
14f9c5c9
AS
8468/* Evaluate the subexpression of EXP starting at *POS as for
8469 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 8470 expression. */
14f9c5c9 8471
d2e4a39e
AS
8472static struct value *
8473evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 8474{
4b27a620 8475 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
8476}
8477
8478/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 8479 value it wraps. */
14f9c5c9 8480
d2e4a39e
AS
8481static struct value *
8482unwrap_value (struct value *val)
14f9c5c9 8483{
df407dfe 8484 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 8485
14f9c5c9
AS
8486 if (ada_is_aligner_type (type))
8487 {
de4d072f 8488 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 8489 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 8490
14f9c5c9 8491 if (ada_type_name (val_type) == NULL)
4c4b4cd2 8492 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
8493
8494 return unwrap_value (v);
8495 }
d2e4a39e 8496 else
14f9c5c9 8497 {
d2e4a39e 8498 struct type *raw_real_type =
61ee279c 8499 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 8500
5bf03f13
JB
8501 /* If there is no parallel XVS or XVE type, then the value is
8502 already unwrapped. Return it without further modification. */
8503 if ((type == raw_real_type)
8504 && ada_find_parallel_type (type, "___XVE") == NULL)
8505 return val;
14f9c5c9 8506
d2e4a39e 8507 return
4c4b4cd2
PH
8508 coerce_unspec_val_to_type
8509 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 8510 value_address (val),
1ed6ede0 8511 NULL, 1));
14f9c5c9
AS
8512 }
8513}
d2e4a39e
AS
8514
8515static struct value *
8516cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
8517{
8518 LONGEST val;
8519
df407dfe 8520 if (type == value_type (arg))
14f9c5c9 8521 return arg;
df407dfe 8522 else if (ada_is_fixed_point_type (value_type (arg)))
d2e4a39e 8523 val = ada_float_to_fixed (type,
df407dfe 8524 ada_fixed_to_float (value_type (arg),
4c4b4cd2 8525 value_as_long (arg)));
d2e4a39e 8526 else
14f9c5c9 8527 {
a53b7a21 8528 DOUBLEST argd = value_as_double (arg);
5b4ee69b 8529
14f9c5c9
AS
8530 val = ada_float_to_fixed (type, argd);
8531 }
8532
8533 return value_from_longest (type, val);
8534}
8535
d2e4a39e 8536static struct value *
a53b7a21 8537cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 8538{
df407dfe 8539 DOUBLEST val = ada_fixed_to_float (value_type (arg),
4c4b4cd2 8540 value_as_long (arg));
5b4ee69b 8541
a53b7a21 8542 return value_from_double (type, val);
14f9c5c9
AS
8543}
8544
4c4b4cd2
PH
8545/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8546 return the converted value. */
8547
d2e4a39e
AS
8548static struct value *
8549coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 8550{
df407dfe 8551 struct type *type2 = value_type (val);
5b4ee69b 8552
14f9c5c9
AS
8553 if (type == type2)
8554 return val;
8555
61ee279c
PH
8556 type2 = ada_check_typedef (type2);
8557 type = ada_check_typedef (type);
14f9c5c9 8558
d2e4a39e
AS
8559 if (TYPE_CODE (type2) == TYPE_CODE_PTR
8560 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
8561 {
8562 val = ada_value_ind (val);
df407dfe 8563 type2 = value_type (val);
14f9c5c9
AS
8564 }
8565
d2e4a39e 8566 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
8567 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
8568 {
8569 if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
4c4b4cd2
PH
8570 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8571 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
323e0a4a 8572 error (_("Incompatible types in assignment"));
04624583 8573 deprecated_set_value_type (val, type);
14f9c5c9 8574 }
d2e4a39e 8575 return val;
14f9c5c9
AS
8576}
8577
4c4b4cd2
PH
8578static struct value *
8579ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
8580{
8581 struct value *val;
8582 struct type *type1, *type2;
8583 LONGEST v, v1, v2;
8584
994b9211
AC
8585 arg1 = coerce_ref (arg1);
8586 arg2 = coerce_ref (arg2);
18af8284
JB
8587 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
8588 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 8589
76a01679
JB
8590 if (TYPE_CODE (type1) != TYPE_CODE_INT
8591 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
8592 return value_binop (arg1, arg2, op);
8593
76a01679 8594 switch (op)
4c4b4cd2
PH
8595 {
8596 case BINOP_MOD:
8597 case BINOP_DIV:
8598 case BINOP_REM:
8599 break;
8600 default:
8601 return value_binop (arg1, arg2, op);
8602 }
8603
8604 v2 = value_as_long (arg2);
8605 if (v2 == 0)
323e0a4a 8606 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
8607
8608 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
8609 return value_binop (arg1, arg2, op);
8610
8611 v1 = value_as_long (arg1);
8612 switch (op)
8613 {
8614 case BINOP_DIV:
8615 v = v1 / v2;
76a01679
JB
8616 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
8617 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
8618 break;
8619 case BINOP_REM:
8620 v = v1 % v2;
76a01679
JB
8621 if (v * v1 < 0)
8622 v -= v2;
4c4b4cd2
PH
8623 break;
8624 default:
8625 /* Should not reach this point. */
8626 v = 0;
8627 }
8628
8629 val = allocate_value (type1);
990a07ab 8630 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
8631 TYPE_LENGTH (value_type (val)),
8632 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
8633 return val;
8634}
8635
8636static int
8637ada_value_equal (struct value *arg1, struct value *arg2)
8638{
df407dfe
AC
8639 if (ada_is_direct_array_type (value_type (arg1))
8640 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 8641 {
f58b38bf
JB
8642 /* Automatically dereference any array reference before
8643 we attempt to perform the comparison. */
8644 arg1 = ada_coerce_ref (arg1);
8645 arg2 = ada_coerce_ref (arg2);
8646
4c4b4cd2
PH
8647 arg1 = ada_coerce_to_simple_array (arg1);
8648 arg2 = ada_coerce_to_simple_array (arg2);
df407dfe
AC
8649 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
8650 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
323e0a4a 8651 error (_("Attempt to compare array with non-array"));
4c4b4cd2 8652 /* FIXME: The following works only for types whose
76a01679
JB
8653 representations use all bits (no padding or undefined bits)
8654 and do not have user-defined equality. */
8655 return
df407dfe 8656 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
0fd88904 8657 && memcmp (value_contents (arg1), value_contents (arg2),
df407dfe 8658 TYPE_LENGTH (value_type (arg1))) == 0;
4c4b4cd2
PH
8659 }
8660 return value_equal (arg1, arg2);
8661}
8662
52ce6436
PH
8663/* Total number of component associations in the aggregate starting at
8664 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 8665 OP_AGGREGATE. */
52ce6436
PH
8666
8667static int
8668num_component_specs (struct expression *exp, int pc)
8669{
8670 int n, m, i;
5b4ee69b 8671
52ce6436
PH
8672 m = exp->elts[pc + 1].longconst;
8673 pc += 3;
8674 n = 0;
8675 for (i = 0; i < m; i += 1)
8676 {
8677 switch (exp->elts[pc].opcode)
8678 {
8679 default:
8680 n += 1;
8681 break;
8682 case OP_CHOICES:
8683 n += exp->elts[pc + 1].longconst;
8684 break;
8685 }
8686 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
8687 }
8688 return n;
8689}
8690
8691/* Assign the result of evaluating EXP starting at *POS to the INDEXth
8692 component of LHS (a simple array or a record), updating *POS past
8693 the expression, assuming that LHS is contained in CONTAINER. Does
8694 not modify the inferior's memory, nor does it modify LHS (unless
8695 LHS == CONTAINER). */
8696
8697static void
8698assign_component (struct value *container, struct value *lhs, LONGEST index,
8699 struct expression *exp, int *pos)
8700{
8701 struct value *mark = value_mark ();
8702 struct value *elt;
5b4ee69b 8703
52ce6436
PH
8704 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
8705 {
22601c15
UW
8706 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
8707 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 8708
52ce6436
PH
8709 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
8710 }
8711 else
8712 {
8713 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 8714 elt = ada_to_fixed_value (elt);
52ce6436
PH
8715 }
8716
8717 if (exp->elts[*pos].opcode == OP_AGGREGATE)
8718 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
8719 else
8720 value_assign_to_component (container, elt,
8721 ada_evaluate_subexp (NULL, exp, pos,
8722 EVAL_NORMAL));
8723
8724 value_free_to_mark (mark);
8725}
8726
8727/* Assuming that LHS represents an lvalue having a record or array
8728 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
8729 of that aggregate's value to LHS, advancing *POS past the
8730 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
8731 lvalue containing LHS (possibly LHS itself). Does not modify
8732 the inferior's memory, nor does it modify the contents of
0963b4bd 8733 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
8734
8735static struct value *
8736assign_aggregate (struct value *container,
8737 struct value *lhs, struct expression *exp,
8738 int *pos, enum noside noside)
8739{
8740 struct type *lhs_type;
8741 int n = exp->elts[*pos+1].longconst;
8742 LONGEST low_index, high_index;
8743 int num_specs;
8744 LONGEST *indices;
8745 int max_indices, num_indices;
8746 int is_array_aggregate;
8747 int i;
52ce6436
PH
8748
8749 *pos += 3;
8750 if (noside != EVAL_NORMAL)
8751 {
52ce6436
PH
8752 for (i = 0; i < n; i += 1)
8753 ada_evaluate_subexp (NULL, exp, pos, noside);
8754 return container;
8755 }
8756
8757 container = ada_coerce_ref (container);
8758 if (ada_is_direct_array_type (value_type (container)))
8759 container = ada_coerce_to_simple_array (container);
8760 lhs = ada_coerce_ref (lhs);
8761 if (!deprecated_value_modifiable (lhs))
8762 error (_("Left operand of assignment is not a modifiable lvalue."));
8763
8764 lhs_type = value_type (lhs);
8765 if (ada_is_direct_array_type (lhs_type))
8766 {
8767 lhs = ada_coerce_to_simple_array (lhs);
8768 lhs_type = value_type (lhs);
8769 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
8770 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
8771 is_array_aggregate = 1;
8772 }
8773 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
8774 {
8775 low_index = 0;
8776 high_index = num_visible_fields (lhs_type) - 1;
8777 is_array_aggregate = 0;
8778 }
8779 else
8780 error (_("Left-hand side must be array or record."));
8781
8782 num_specs = num_component_specs (exp, *pos - 3);
8783 max_indices = 4 * num_specs + 4;
8784 indices = alloca (max_indices * sizeof (indices[0]));
8785 indices[0] = indices[1] = low_index - 1;
8786 indices[2] = indices[3] = high_index + 1;
8787 num_indices = 4;
8788
8789 for (i = 0; i < n; i += 1)
8790 {
8791 switch (exp->elts[*pos].opcode)
8792 {
1fbf5ada
JB
8793 case OP_CHOICES:
8794 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
8795 &num_indices, max_indices,
8796 low_index, high_index);
8797 break;
8798 case OP_POSITIONAL:
8799 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
8800 &num_indices, max_indices,
8801 low_index, high_index);
1fbf5ada
JB
8802 break;
8803 case OP_OTHERS:
8804 if (i != n-1)
8805 error (_("Misplaced 'others' clause"));
8806 aggregate_assign_others (container, lhs, exp, pos, indices,
8807 num_indices, low_index, high_index);
8808 break;
8809 default:
8810 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
8811 }
8812 }
8813
8814 return container;
8815}
8816
8817/* Assign into the component of LHS indexed by the OP_POSITIONAL
8818 construct at *POS, updating *POS past the construct, given that
8819 the positions are relative to lower bound LOW, where HIGH is the
8820 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
8821 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 8822 assign_aggregate. */
52ce6436
PH
8823static void
8824aggregate_assign_positional (struct value *container,
8825 struct value *lhs, struct expression *exp,
8826 int *pos, LONGEST *indices, int *num_indices,
8827 int max_indices, LONGEST low, LONGEST high)
8828{
8829 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
8830
8831 if (ind - 1 == high)
e1d5a0d2 8832 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
8833 if (ind <= high)
8834 {
8835 add_component_interval (ind, ind, indices, num_indices, max_indices);
8836 *pos += 3;
8837 assign_component (container, lhs, ind, exp, pos);
8838 }
8839 else
8840 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8841}
8842
8843/* Assign into the components of LHS indexed by the OP_CHOICES
8844 construct at *POS, updating *POS past the construct, given that
8845 the allowable indices are LOW..HIGH. Record the indices assigned
8846 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 8847 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
8848static void
8849aggregate_assign_from_choices (struct value *container,
8850 struct value *lhs, struct expression *exp,
8851 int *pos, LONGEST *indices, int *num_indices,
8852 int max_indices, LONGEST low, LONGEST high)
8853{
8854 int j;
8855 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
8856 int choice_pos, expr_pc;
8857 int is_array = ada_is_direct_array_type (value_type (lhs));
8858
8859 choice_pos = *pos += 3;
8860
8861 for (j = 0; j < n_choices; j += 1)
8862 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8863 expr_pc = *pos;
8864 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8865
8866 for (j = 0; j < n_choices; j += 1)
8867 {
8868 LONGEST lower, upper;
8869 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 8870
52ce6436
PH
8871 if (op == OP_DISCRETE_RANGE)
8872 {
8873 choice_pos += 1;
8874 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8875 EVAL_NORMAL));
8876 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8877 EVAL_NORMAL));
8878 }
8879 else if (is_array)
8880 {
8881 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
8882 EVAL_NORMAL));
8883 upper = lower;
8884 }
8885 else
8886 {
8887 int ind;
0d5cff50 8888 const char *name;
5b4ee69b 8889
52ce6436
PH
8890 switch (op)
8891 {
8892 case OP_NAME:
8893 name = &exp->elts[choice_pos + 2].string;
8894 break;
8895 case OP_VAR_VALUE:
8896 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
8897 break;
8898 default:
8899 error (_("Invalid record component association."));
8900 }
8901 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
8902 ind = 0;
8903 if (! find_struct_field (name, value_type (lhs), 0,
8904 NULL, NULL, NULL, NULL, &ind))
8905 error (_("Unknown component name: %s."), name);
8906 lower = upper = ind;
8907 }
8908
8909 if (lower <= upper && (lower < low || upper > high))
8910 error (_("Index in component association out of bounds."));
8911
8912 add_component_interval (lower, upper, indices, num_indices,
8913 max_indices);
8914 while (lower <= upper)
8915 {
8916 int pos1;
5b4ee69b 8917
52ce6436
PH
8918 pos1 = expr_pc;
8919 assign_component (container, lhs, lower, exp, &pos1);
8920 lower += 1;
8921 }
8922 }
8923}
8924
8925/* Assign the value of the expression in the OP_OTHERS construct in
8926 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8927 have not been previously assigned. The index intervals already assigned
8928 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 8929 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
8930static void
8931aggregate_assign_others (struct value *container,
8932 struct value *lhs, struct expression *exp,
8933 int *pos, LONGEST *indices, int num_indices,
8934 LONGEST low, LONGEST high)
8935{
8936 int i;
5ce64950 8937 int expr_pc = *pos + 1;
52ce6436
PH
8938
8939 for (i = 0; i < num_indices - 2; i += 2)
8940 {
8941 LONGEST ind;
5b4ee69b 8942
52ce6436
PH
8943 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
8944 {
5ce64950 8945 int localpos;
5b4ee69b 8946
5ce64950
MS
8947 localpos = expr_pc;
8948 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
8949 }
8950 }
8951 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8952}
8953
8954/* Add the interval [LOW .. HIGH] to the sorted set of intervals
8955 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8956 modifying *SIZE as needed. It is an error if *SIZE exceeds
8957 MAX_SIZE. The resulting intervals do not overlap. */
8958static void
8959add_component_interval (LONGEST low, LONGEST high,
8960 LONGEST* indices, int *size, int max_size)
8961{
8962 int i, j;
5b4ee69b 8963
52ce6436
PH
8964 for (i = 0; i < *size; i += 2) {
8965 if (high >= indices[i] && low <= indices[i + 1])
8966 {
8967 int kh;
5b4ee69b 8968
52ce6436
PH
8969 for (kh = i + 2; kh < *size; kh += 2)
8970 if (high < indices[kh])
8971 break;
8972 if (low < indices[i])
8973 indices[i] = low;
8974 indices[i + 1] = indices[kh - 1];
8975 if (high > indices[i + 1])
8976 indices[i + 1] = high;
8977 memcpy (indices + i + 2, indices + kh, *size - kh);
8978 *size -= kh - i - 2;
8979 return;
8980 }
8981 else if (high < indices[i])
8982 break;
8983 }
8984
8985 if (*size == max_size)
8986 error (_("Internal error: miscounted aggregate components."));
8987 *size += 2;
8988 for (j = *size-1; j >= i+2; j -= 1)
8989 indices[j] = indices[j - 2];
8990 indices[i] = low;
8991 indices[i + 1] = high;
8992}
8993
6e48bd2c
JB
8994/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8995 is different. */
8996
8997static struct value *
8998ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
8999{
9000 if (type == ada_check_typedef (value_type (arg2)))
9001 return arg2;
9002
9003 if (ada_is_fixed_point_type (type))
9004 return (cast_to_fixed (type, arg2));
9005
9006 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9007 return cast_from_fixed (type, arg2);
6e48bd2c
JB
9008
9009 return value_cast (type, arg2);
9010}
9011
284614f0
JB
9012/* Evaluating Ada expressions, and printing their result.
9013 ------------------------------------------------------
9014
21649b50
JB
9015 1. Introduction:
9016 ----------------
9017
284614f0
JB
9018 We usually evaluate an Ada expression in order to print its value.
9019 We also evaluate an expression in order to print its type, which
9020 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9021 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9022 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9023 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9024 similar.
9025
9026 Evaluating expressions is a little more complicated for Ada entities
9027 than it is for entities in languages such as C. The main reason for
9028 this is that Ada provides types whose definition might be dynamic.
9029 One example of such types is variant records. Or another example
9030 would be an array whose bounds can only be known at run time.
9031
9032 The following description is a general guide as to what should be
9033 done (and what should NOT be done) in order to evaluate an expression
9034 involving such types, and when. This does not cover how the semantic
9035 information is encoded by GNAT as this is covered separatly. For the
9036 document used as the reference for the GNAT encoding, see exp_dbug.ads
9037 in the GNAT sources.
9038
9039 Ideally, we should embed each part of this description next to its
9040 associated code. Unfortunately, the amount of code is so vast right
9041 now that it's hard to see whether the code handling a particular
9042 situation might be duplicated or not. One day, when the code is
9043 cleaned up, this guide might become redundant with the comments
9044 inserted in the code, and we might want to remove it.
9045
21649b50
JB
9046 2. ``Fixing'' an Entity, the Simple Case:
9047 -----------------------------------------
9048
284614f0
JB
9049 When evaluating Ada expressions, the tricky issue is that they may
9050 reference entities whose type contents and size are not statically
9051 known. Consider for instance a variant record:
9052
9053 type Rec (Empty : Boolean := True) is record
9054 case Empty is
9055 when True => null;
9056 when False => Value : Integer;
9057 end case;
9058 end record;
9059 Yes : Rec := (Empty => False, Value => 1);
9060 No : Rec := (empty => True);
9061
9062 The size and contents of that record depends on the value of the
9063 descriminant (Rec.Empty). At this point, neither the debugging
9064 information nor the associated type structure in GDB are able to
9065 express such dynamic types. So what the debugger does is to create
9066 "fixed" versions of the type that applies to the specific object.
9067 We also informally refer to this opperation as "fixing" an object,
9068 which means creating its associated fixed type.
9069
9070 Example: when printing the value of variable "Yes" above, its fixed
9071 type would look like this:
9072
9073 type Rec is record
9074 Empty : Boolean;
9075 Value : Integer;
9076 end record;
9077
9078 On the other hand, if we printed the value of "No", its fixed type
9079 would become:
9080
9081 type Rec is record
9082 Empty : Boolean;
9083 end record;
9084
9085 Things become a little more complicated when trying to fix an entity
9086 with a dynamic type that directly contains another dynamic type,
9087 such as an array of variant records, for instance. There are
9088 two possible cases: Arrays, and records.
9089
21649b50
JB
9090 3. ``Fixing'' Arrays:
9091 ---------------------
9092
9093 The type structure in GDB describes an array in terms of its bounds,
9094 and the type of its elements. By design, all elements in the array
9095 have the same type and we cannot represent an array of variant elements
9096 using the current type structure in GDB. When fixing an array,
9097 we cannot fix the array element, as we would potentially need one
9098 fixed type per element of the array. As a result, the best we can do
9099 when fixing an array is to produce an array whose bounds and size
9100 are correct (allowing us to read it from memory), but without having
9101 touched its element type. Fixing each element will be done later,
9102 when (if) necessary.
9103
9104 Arrays are a little simpler to handle than records, because the same
9105 amount of memory is allocated for each element of the array, even if
1b536f04 9106 the amount of space actually used by each element differs from element
21649b50 9107 to element. Consider for instance the following array of type Rec:
284614f0
JB
9108
9109 type Rec_Array is array (1 .. 2) of Rec;
9110
1b536f04
JB
9111 The actual amount of memory occupied by each element might be different
9112 from element to element, depending on the value of their discriminant.
21649b50 9113 But the amount of space reserved for each element in the array remains
1b536f04 9114 fixed regardless. So we simply need to compute that size using
21649b50
JB
9115 the debugging information available, from which we can then determine
9116 the array size (we multiply the number of elements of the array by
9117 the size of each element).
9118
9119 The simplest case is when we have an array of a constrained element
9120 type. For instance, consider the following type declarations:
9121
9122 type Bounded_String (Max_Size : Integer) is
9123 Length : Integer;
9124 Buffer : String (1 .. Max_Size);
9125 end record;
9126 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9127
9128 In this case, the compiler describes the array as an array of
9129 variable-size elements (identified by its XVS suffix) for which
9130 the size can be read in the parallel XVZ variable.
9131
9132 In the case of an array of an unconstrained element type, the compiler
9133 wraps the array element inside a private PAD type. This type should not
9134 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
9135 that we also use the adjective "aligner" in our code to designate
9136 these wrapper types.
9137
1b536f04 9138 In some cases, the size allocated for each element is statically
21649b50
JB
9139 known. In that case, the PAD type already has the correct size,
9140 and the array element should remain unfixed.
9141
9142 But there are cases when this size is not statically known.
9143 For instance, assuming that "Five" is an integer variable:
284614f0
JB
9144
9145 type Dynamic is array (1 .. Five) of Integer;
9146 type Wrapper (Has_Length : Boolean := False) is record
9147 Data : Dynamic;
9148 case Has_Length is
9149 when True => Length : Integer;
9150 when False => null;
9151 end case;
9152 end record;
9153 type Wrapper_Array is array (1 .. 2) of Wrapper;
9154
9155 Hello : Wrapper_Array := (others => (Has_Length => True,
9156 Data => (others => 17),
9157 Length => 1));
9158
9159
9160 The debugging info would describe variable Hello as being an
9161 array of a PAD type. The size of that PAD type is not statically
9162 known, but can be determined using a parallel XVZ variable.
9163 In that case, a copy of the PAD type with the correct size should
9164 be used for the fixed array.
9165
21649b50
JB
9166 3. ``Fixing'' record type objects:
9167 ----------------------------------
9168
9169 Things are slightly different from arrays in the case of dynamic
284614f0
JB
9170 record types. In this case, in order to compute the associated
9171 fixed type, we need to determine the size and offset of each of
9172 its components. This, in turn, requires us to compute the fixed
9173 type of each of these components.
9174
9175 Consider for instance the example:
9176
9177 type Bounded_String (Max_Size : Natural) is record
9178 Str : String (1 .. Max_Size);
9179 Length : Natural;
9180 end record;
9181 My_String : Bounded_String (Max_Size => 10);
9182
9183 In that case, the position of field "Length" depends on the size
9184 of field Str, which itself depends on the value of the Max_Size
21649b50 9185 discriminant. In order to fix the type of variable My_String,
284614f0
JB
9186 we need to fix the type of field Str. Therefore, fixing a variant
9187 record requires us to fix each of its components.
9188
9189 However, if a component does not have a dynamic size, the component
9190 should not be fixed. In particular, fields that use a PAD type
9191 should not fixed. Here is an example where this might happen
9192 (assuming type Rec above):
9193
9194 type Container (Big : Boolean) is record
9195 First : Rec;
9196 After : Integer;
9197 case Big is
9198 when True => Another : Integer;
9199 when False => null;
9200 end case;
9201 end record;
9202 My_Container : Container := (Big => False,
9203 First => (Empty => True),
9204 After => 42);
9205
9206 In that example, the compiler creates a PAD type for component First,
9207 whose size is constant, and then positions the component After just
9208 right after it. The offset of component After is therefore constant
9209 in this case.
9210
9211 The debugger computes the position of each field based on an algorithm
9212 that uses, among other things, the actual position and size of the field
21649b50
JB
9213 preceding it. Let's now imagine that the user is trying to print
9214 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
9215 end up computing the offset of field After based on the size of the
9216 fixed version of field First. And since in our example First has
9217 only one actual field, the size of the fixed type is actually smaller
9218 than the amount of space allocated to that field, and thus we would
9219 compute the wrong offset of field After.
9220
21649b50
JB
9221 To make things more complicated, we need to watch out for dynamic
9222 components of variant records (identified by the ___XVL suffix in
9223 the component name). Even if the target type is a PAD type, the size
9224 of that type might not be statically known. So the PAD type needs
9225 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9226 we might end up with the wrong size for our component. This can be
9227 observed with the following type declarations:
284614f0
JB
9228
9229 type Octal is new Integer range 0 .. 7;
9230 type Octal_Array is array (Positive range <>) of Octal;
9231 pragma Pack (Octal_Array);
9232
9233 type Octal_Buffer (Size : Positive) is record
9234 Buffer : Octal_Array (1 .. Size);
9235 Length : Integer;
9236 end record;
9237
9238 In that case, Buffer is a PAD type whose size is unset and needs
9239 to be computed by fixing the unwrapped type.
9240
21649b50
JB
9241 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9242 ----------------------------------------------------------
9243
9244 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
9245 thus far, be actually fixed?
9246
9247 The answer is: Only when referencing that element. For instance
9248 when selecting one component of a record, this specific component
9249 should be fixed at that point in time. Or when printing the value
9250 of a record, each component should be fixed before its value gets
9251 printed. Similarly for arrays, the element of the array should be
9252 fixed when printing each element of the array, or when extracting
9253 one element out of that array. On the other hand, fixing should
9254 not be performed on the elements when taking a slice of an array!
9255
9256 Note that one of the side-effects of miscomputing the offset and
9257 size of each field is that we end up also miscomputing the size
9258 of the containing type. This can have adverse results when computing
9259 the value of an entity. GDB fetches the value of an entity based
9260 on the size of its type, and thus a wrong size causes GDB to fetch
9261 the wrong amount of memory. In the case where the computed size is
9262 too small, GDB fetches too little data to print the value of our
9263 entiry. Results in this case as unpredicatble, as we usually read
9264 past the buffer containing the data =:-o. */
9265
9266/* Implement the evaluate_exp routine in the exp_descriptor structure
9267 for the Ada language. */
9268
52ce6436 9269static struct value *
ebf56fd3 9270ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 9271 int *pos, enum noside noside)
14f9c5c9
AS
9272{
9273 enum exp_opcode op;
b5385fc0 9274 int tem;
14f9c5c9
AS
9275 int pc;
9276 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
9277 struct type *type;
52ce6436 9278 int nargs, oplen;
d2e4a39e 9279 struct value **argvec;
14f9c5c9 9280
d2e4a39e
AS
9281 pc = *pos;
9282 *pos += 1;
14f9c5c9
AS
9283 op = exp->elts[pc].opcode;
9284
d2e4a39e 9285 switch (op)
14f9c5c9
AS
9286 {
9287 default:
9288 *pos -= 1;
6e48bd2c
JB
9289 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
9290 arg1 = unwrap_value (arg1);
9291
9292 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
9293 then we need to perform the conversion manually, because
9294 evaluate_subexp_standard doesn't do it. This conversion is
9295 necessary in Ada because the different kinds of float/fixed
9296 types in Ada have different representations.
9297
9298 Similarly, we need to perform the conversion from OP_LONG
9299 ourselves. */
9300 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
9301 arg1 = ada_value_cast (expect_type, arg1, noside);
9302
9303 return arg1;
4c4b4cd2
PH
9304
9305 case OP_STRING:
9306 {
76a01679 9307 struct value *result;
5b4ee69b 9308
76a01679
JB
9309 *pos -= 1;
9310 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
9311 /* The result type will have code OP_STRING, bashed there from
9312 OP_ARRAY. Bash it back. */
df407dfe
AC
9313 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
9314 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 9315 return result;
4c4b4cd2 9316 }
14f9c5c9
AS
9317
9318 case UNOP_CAST:
9319 (*pos) += 2;
9320 type = exp->elts[pc + 1].type;
9321 arg1 = evaluate_subexp (type, exp, pos, noside);
9322 if (noside == EVAL_SKIP)
4c4b4cd2 9323 goto nosideret;
6e48bd2c 9324 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
9325 return arg1;
9326
4c4b4cd2
PH
9327 case UNOP_QUAL:
9328 (*pos) += 2;
9329 type = exp->elts[pc + 1].type;
9330 return ada_evaluate_subexp (type, exp, pos, noside);
9331
14f9c5c9
AS
9332 case BINOP_ASSIGN:
9333 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
9334 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9335 {
9336 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
9337 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
9338 return arg1;
9339 return ada_value_assign (arg1, arg1);
9340 }
003f3813
JB
9341 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9342 except if the lhs of our assignment is a convenience variable.
9343 In the case of assigning to a convenience variable, the lhs
9344 should be exactly the result of the evaluation of the rhs. */
9345 type = value_type (arg1);
9346 if (VALUE_LVAL (arg1) == lval_internalvar)
9347 type = NULL;
9348 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 9349 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 9350 return arg1;
df407dfe
AC
9351 if (ada_is_fixed_point_type (value_type (arg1)))
9352 arg2 = cast_to_fixed (value_type (arg1), arg2);
9353 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 9354 error
323e0a4a 9355 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 9356 else
df407dfe 9357 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 9358 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
9359
9360 case BINOP_ADD:
9361 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9362 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9363 if (noside == EVAL_SKIP)
4c4b4cd2 9364 goto nosideret;
2ac8a782
JB
9365 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9366 return (value_from_longest
9367 (value_type (arg1),
9368 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
9369 if ((ada_is_fixed_point_type (value_type (arg1))
9370 || ada_is_fixed_point_type (value_type (arg2)))
9371 && value_type (arg1) != value_type (arg2))
323e0a4a 9372 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
9373 /* Do the addition, and cast the result to the type of the first
9374 argument. We cannot cast the result to a reference type, so if
9375 ARG1 is a reference type, find its underlying type. */
9376 type = value_type (arg1);
9377 while (TYPE_CODE (type) == TYPE_CODE_REF)
9378 type = TYPE_TARGET_TYPE (type);
f44316fa 9379 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 9380 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
9381
9382 case BINOP_SUB:
9383 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9384 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9385 if (noside == EVAL_SKIP)
4c4b4cd2 9386 goto nosideret;
2ac8a782
JB
9387 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9388 return (value_from_longest
9389 (value_type (arg1),
9390 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
9391 if ((ada_is_fixed_point_type (value_type (arg1))
9392 || ada_is_fixed_point_type (value_type (arg2)))
9393 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
9394 error (_("Operands of fixed-point subtraction "
9395 "must have the same type"));
b7789565
JB
9396 /* Do the substraction, and cast the result to the type of the first
9397 argument. We cannot cast the result to a reference type, so if
9398 ARG1 is a reference type, find its underlying type. */
9399 type = value_type (arg1);
9400 while (TYPE_CODE (type) == TYPE_CODE_REF)
9401 type = TYPE_TARGET_TYPE (type);
f44316fa 9402 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 9403 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
9404
9405 case BINOP_MUL:
9406 case BINOP_DIV:
e1578042
JB
9407 case BINOP_REM:
9408 case BINOP_MOD:
14f9c5c9
AS
9409 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9410 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9411 if (noside == EVAL_SKIP)
4c4b4cd2 9412 goto nosideret;
e1578042 9413 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
9414 {
9415 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9416 return value_zero (value_type (arg1), not_lval);
9417 }
14f9c5c9 9418 else
4c4b4cd2 9419 {
a53b7a21 9420 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 9421 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 9422 arg1 = cast_from_fixed (type, arg1);
df407dfe 9423 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9424 arg2 = cast_from_fixed (type, arg2);
f44316fa 9425 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
9426 return ada_value_binop (arg1, arg2, op);
9427 }
9428
4c4b4cd2
PH
9429 case BINOP_EQUAL:
9430 case BINOP_NOTEQUAL:
14f9c5c9 9431 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 9432 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 9433 if (noside == EVAL_SKIP)
76a01679 9434 goto nosideret;
4c4b4cd2 9435 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9436 tem = 0;
4c4b4cd2 9437 else
f44316fa
UW
9438 {
9439 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9440 tem = ada_value_equal (arg1, arg2);
9441 }
4c4b4cd2 9442 if (op == BINOP_NOTEQUAL)
76a01679 9443 tem = !tem;
fbb06eb1
UW
9444 type = language_bool_type (exp->language_defn, exp->gdbarch);
9445 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
9446
9447 case UNOP_NEG:
9448 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9449 if (noside == EVAL_SKIP)
9450 goto nosideret;
df407dfe
AC
9451 else if (ada_is_fixed_point_type (value_type (arg1)))
9452 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 9453 else
f44316fa
UW
9454 {
9455 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9456 return value_neg (arg1);
9457 }
4c4b4cd2 9458
2330c6c6
JB
9459 case BINOP_LOGICAL_AND:
9460 case BINOP_LOGICAL_OR:
9461 case UNOP_LOGICAL_NOT:
000d5124
JB
9462 {
9463 struct value *val;
9464
9465 *pos -= 1;
9466 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
9467 type = language_bool_type (exp->language_defn, exp->gdbarch);
9468 return value_cast (type, val);
000d5124 9469 }
2330c6c6
JB
9470
9471 case BINOP_BITWISE_AND:
9472 case BINOP_BITWISE_IOR:
9473 case BINOP_BITWISE_XOR:
000d5124
JB
9474 {
9475 struct value *val;
9476
9477 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
9478 *pos = pc;
9479 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
9480
9481 return value_cast (value_type (arg1), val);
9482 }
2330c6c6 9483
14f9c5c9
AS
9484 case OP_VAR_VALUE:
9485 *pos -= 1;
6799def4 9486
14f9c5c9 9487 if (noside == EVAL_SKIP)
4c4b4cd2
PH
9488 {
9489 *pos += 4;
9490 goto nosideret;
9491 }
9492 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
9493 /* Only encountered when an unresolved symbol occurs in a
9494 context other than a function call, in which case, it is
52ce6436 9495 invalid. */
323e0a4a 9496 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 9497 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
14f9c5c9 9498 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 9499 {
0c1f74cf 9500 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
9501 /* Check to see if this is a tagged type. We also need to handle
9502 the case where the type is a reference to a tagged type, but
9503 we have to be careful to exclude pointers to tagged types.
9504 The latter should be shown as usual (as a pointer), whereas
9505 a reference should mostly be transparent to the user. */
9506 if (ada_is_tagged_type (type, 0)
9507 || (TYPE_CODE(type) == TYPE_CODE_REF
9508 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0c1f74cf
JB
9509 {
9510 /* Tagged types are a little special in the fact that the real
9511 type is dynamic and can only be determined by inspecting the
9512 object's tag. This means that we need to get the object's
9513 value first (EVAL_NORMAL) and then extract the actual object
9514 type from its tag.
9515
9516 Note that we cannot skip the final step where we extract
9517 the object type from its tag, because the EVAL_NORMAL phase
9518 results in dynamic components being resolved into fixed ones.
9519 This can cause problems when trying to print the type
9520 description of tagged types whose parent has a dynamic size:
9521 We use the type name of the "_parent" component in order
9522 to print the name of the ancestor type in the type description.
9523 If that component had a dynamic size, the resolution into
9524 a fixed type would result in the loss of that type name,
9525 thus preventing us from printing the name of the ancestor
9526 type in the type description. */
b79819ba
JB
9527 struct type *actual_type;
9528
0c1f74cf 9529 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
b79819ba
JB
9530 actual_type = type_from_tag (ada_value_tag (arg1));
9531 if (actual_type == NULL)
9532 /* If, for some reason, we were unable to determine
9533 the actual type from the tag, then use the static
9534 approximation that we just computed as a fallback.
9535 This can happen if the debugging information is
9536 incomplete, for instance. */
9537 actual_type = type;
9538
9539 return value_zero (actual_type, not_lval);
0c1f74cf
JB
9540 }
9541
4c4b4cd2
PH
9542 *pos += 4;
9543 return value_zero
9544 (to_static_fixed_type
9545 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
9546 not_lval);
9547 }
d2e4a39e 9548 else
4c4b4cd2 9549 {
284614f0 9550 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
4c4b4cd2
PH
9551 return ada_to_fixed_value (arg1);
9552 }
9553
9554 case OP_FUNCALL:
9555 (*pos) += 2;
9556
9557 /* Allocate arg vector, including space for the function to be
9558 called in argvec[0] and a terminating NULL. */
9559 nargs = longest_to_int (exp->elts[pc + 1].longconst);
9560 argvec =
9561 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
9562
9563 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 9564 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 9565 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
9566 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
9567 else
9568 {
9569 for (tem = 0; tem <= nargs; tem += 1)
9570 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9571 argvec[tem] = 0;
9572
9573 if (noside == EVAL_SKIP)
9574 goto nosideret;
9575 }
9576
ad82864c
JB
9577 if (ada_is_constrained_packed_array_type
9578 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 9579 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
9580 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
9581 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
9582 /* This is a packed array that has already been fixed, and
9583 therefore already coerced to a simple array. Nothing further
9584 to do. */
9585 ;
df407dfe
AC
9586 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
9587 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
76a01679 9588 && VALUE_LVAL (argvec[0]) == lval_memory))
4c4b4cd2
PH
9589 argvec[0] = value_addr (argvec[0]);
9590
df407dfe 9591 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
9592
9593 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
9594 them. So, if this is an array typedef (encoding use for array
9595 access types encoded as fat pointers), strip it now. */
720d1a40
JB
9596 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
9597 type = ada_typedef_target_type (type);
9598
4c4b4cd2
PH
9599 if (TYPE_CODE (type) == TYPE_CODE_PTR)
9600 {
61ee279c 9601 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
9602 {
9603 case TYPE_CODE_FUNC:
61ee279c 9604 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
9605 break;
9606 case TYPE_CODE_ARRAY:
9607 break;
9608 case TYPE_CODE_STRUCT:
9609 if (noside != EVAL_AVOID_SIDE_EFFECTS)
9610 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 9611 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
9612 break;
9613 default:
323e0a4a 9614 error (_("cannot subscript or call something of type `%s'"),
df407dfe 9615 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
9616 break;
9617 }
9618 }
9619
9620 switch (TYPE_CODE (type))
9621 {
9622 case TYPE_CODE_FUNC:
9623 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9624 return allocate_value (TYPE_TARGET_TYPE (type));
9625 return call_function_by_hand (argvec[0], nargs, argvec + 1);
9626 case TYPE_CODE_STRUCT:
9627 {
9628 int arity;
9629
4c4b4cd2
PH
9630 arity = ada_array_arity (type);
9631 type = ada_array_element_type (type, nargs);
9632 if (type == NULL)
323e0a4a 9633 error (_("cannot subscript or call a record"));
4c4b4cd2 9634 if (arity != nargs)
323e0a4a 9635 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 9636 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 9637 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
9638 return
9639 unwrap_value (ada_value_subscript
9640 (argvec[0], nargs, argvec + 1));
9641 }
9642 case TYPE_CODE_ARRAY:
9643 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9644 {
9645 type = ada_array_element_type (type, nargs);
9646 if (type == NULL)
323e0a4a 9647 error (_("element type of array unknown"));
4c4b4cd2 9648 else
0a07e705 9649 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
9650 }
9651 return
9652 unwrap_value (ada_value_subscript
9653 (ada_coerce_to_simple_array (argvec[0]),
9654 nargs, argvec + 1));
9655 case TYPE_CODE_PTR: /* Pointer to array */
9656 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
9657 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9658 {
9659 type = ada_array_element_type (type, nargs);
9660 if (type == NULL)
323e0a4a 9661 error (_("element type of array unknown"));
4c4b4cd2 9662 else
0a07e705 9663 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
9664 }
9665 return
9666 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
9667 nargs, argvec + 1));
9668
9669 default:
e1d5a0d2
PH
9670 error (_("Attempt to index or call something other than an "
9671 "array or function"));
4c4b4cd2
PH
9672 }
9673
9674 case TERNOP_SLICE:
9675 {
9676 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9677 struct value *low_bound_val =
9678 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
9679 struct value *high_bound_val =
9680 evaluate_subexp (NULL_TYPE, exp, pos, noside);
9681 LONGEST low_bound;
9682 LONGEST high_bound;
5b4ee69b 9683
994b9211
AC
9684 low_bound_val = coerce_ref (low_bound_val);
9685 high_bound_val = coerce_ref (high_bound_val);
714e53ab
PH
9686 low_bound = pos_atr (low_bound_val);
9687 high_bound = pos_atr (high_bound_val);
963a6417 9688
4c4b4cd2
PH
9689 if (noside == EVAL_SKIP)
9690 goto nosideret;
9691
4c4b4cd2
PH
9692 /* If this is a reference to an aligner type, then remove all
9693 the aligners. */
df407dfe
AC
9694 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
9695 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
9696 TYPE_TARGET_TYPE (value_type (array)) =
9697 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 9698
ad82864c 9699 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 9700 error (_("cannot slice a packed array"));
4c4b4cd2
PH
9701
9702 /* If this is a reference to an array or an array lvalue,
9703 convert to a pointer. */
df407dfe
AC
9704 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
9705 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
9706 && VALUE_LVAL (array) == lval_memory))
9707 array = value_addr (array);
9708
1265e4aa 9709 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 9710 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 9711 (value_type (array))))
0b5d8877 9712 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
9713
9714 array = ada_coerce_to_simple_array_ptr (array);
9715
714e53ab
PH
9716 /* If we have more than one level of pointer indirection,
9717 dereference the value until we get only one level. */
df407dfe
AC
9718 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
9719 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
9720 == TYPE_CODE_PTR))
9721 array = value_ind (array);
9722
9723 /* Make sure we really do have an array type before going further,
9724 to avoid a SEGV when trying to get the index type or the target
9725 type later down the road if the debug info generated by
9726 the compiler is incorrect or incomplete. */
df407dfe 9727 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 9728 error (_("cannot take slice of non-array"));
714e53ab 9729
828292f2
JB
9730 if (TYPE_CODE (ada_check_typedef (value_type (array)))
9731 == TYPE_CODE_PTR)
4c4b4cd2 9732 {
828292f2
JB
9733 struct type *type0 = ada_check_typedef (value_type (array));
9734
0b5d8877 9735 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 9736 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
9737 else
9738 {
9739 struct type *arr_type0 =
828292f2 9740 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 9741
f5938064
JG
9742 return ada_value_slice_from_ptr (array, arr_type0,
9743 longest_to_int (low_bound),
9744 longest_to_int (high_bound));
4c4b4cd2
PH
9745 }
9746 }
9747 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9748 return array;
9749 else if (high_bound < low_bound)
df407dfe 9750 return empty_array (value_type (array), low_bound);
4c4b4cd2 9751 else
529cad9c
PH
9752 return ada_value_slice (array, longest_to_int (low_bound),
9753 longest_to_int (high_bound));
4c4b4cd2 9754 }
14f9c5c9 9755
4c4b4cd2
PH
9756 case UNOP_IN_RANGE:
9757 (*pos) += 2;
9758 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 9759 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 9760
14f9c5c9 9761 if (noside == EVAL_SKIP)
4c4b4cd2 9762 goto nosideret;
14f9c5c9 9763
4c4b4cd2
PH
9764 switch (TYPE_CODE (type))
9765 {
9766 default:
e1d5a0d2
PH
9767 lim_warning (_("Membership test incompletely implemented; "
9768 "always returns true"));
fbb06eb1
UW
9769 type = language_bool_type (exp->language_defn, exp->gdbarch);
9770 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
9771
9772 case TYPE_CODE_RANGE:
030b4912
UW
9773 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
9774 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
9775 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9776 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
9777 type = language_bool_type (exp->language_defn, exp->gdbarch);
9778 return
9779 value_from_longest (type,
4c4b4cd2
PH
9780 (value_less (arg1, arg3)
9781 || value_equal (arg1, arg3))
9782 && (value_less (arg2, arg1)
9783 || value_equal (arg2, arg1)));
9784 }
9785
9786 case BINOP_IN_BOUNDS:
14f9c5c9 9787 (*pos) += 2;
4c4b4cd2
PH
9788 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9789 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 9790
4c4b4cd2
PH
9791 if (noside == EVAL_SKIP)
9792 goto nosideret;
14f9c5c9 9793
4c4b4cd2 9794 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
9795 {
9796 type = language_bool_type (exp->language_defn, exp->gdbarch);
9797 return value_zero (type, not_lval);
9798 }
14f9c5c9 9799
4c4b4cd2 9800 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 9801
1eea4ebd
UW
9802 type = ada_index_type (value_type (arg2), tem, "range");
9803 if (!type)
9804 type = value_type (arg1);
14f9c5c9 9805
1eea4ebd
UW
9806 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
9807 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 9808
f44316fa
UW
9809 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9810 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 9811 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 9812 return
fbb06eb1 9813 value_from_longest (type,
4c4b4cd2
PH
9814 (value_less (arg1, arg3)
9815 || value_equal (arg1, arg3))
9816 && (value_less (arg2, arg1)
9817 || value_equal (arg2, arg1)));
9818
9819 case TERNOP_IN_RANGE:
9820 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9821 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9822 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9823
9824 if (noside == EVAL_SKIP)
9825 goto nosideret;
9826
f44316fa
UW
9827 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9828 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 9829 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 9830 return
fbb06eb1 9831 value_from_longest (type,
4c4b4cd2
PH
9832 (value_less (arg1, arg3)
9833 || value_equal (arg1, arg3))
9834 && (value_less (arg2, arg1)
9835 || value_equal (arg2, arg1)));
9836
9837 case OP_ATR_FIRST:
9838 case OP_ATR_LAST:
9839 case OP_ATR_LENGTH:
9840 {
76a01679 9841 struct type *type_arg;
5b4ee69b 9842
76a01679
JB
9843 if (exp->elts[*pos].opcode == OP_TYPE)
9844 {
9845 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9846 arg1 = NULL;
5bc23cb3 9847 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
9848 }
9849 else
9850 {
9851 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9852 type_arg = NULL;
9853 }
9854
9855 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 9856 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
9857 tem = longest_to_int (exp->elts[*pos + 2].longconst);
9858 *pos += 4;
9859
9860 if (noside == EVAL_SKIP)
9861 goto nosideret;
9862
9863 if (type_arg == NULL)
9864 {
9865 arg1 = ada_coerce_ref (arg1);
9866
ad82864c 9867 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
9868 arg1 = ada_coerce_to_simple_array (arg1);
9869
1eea4ebd
UW
9870 type = ada_index_type (value_type (arg1), tem,
9871 ada_attribute_name (op));
9872 if (type == NULL)
9873 type = builtin_type (exp->gdbarch)->builtin_int;
76a01679
JB
9874
9875 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 9876 return allocate_value (type);
76a01679
JB
9877
9878 switch (op)
9879 {
9880 default: /* Should never happen. */
323e0a4a 9881 error (_("unexpected attribute encountered"));
76a01679 9882 case OP_ATR_FIRST:
1eea4ebd
UW
9883 return value_from_longest
9884 (type, ada_array_bound (arg1, tem, 0));
76a01679 9885 case OP_ATR_LAST:
1eea4ebd
UW
9886 return value_from_longest
9887 (type, ada_array_bound (arg1, tem, 1));
76a01679 9888 case OP_ATR_LENGTH:
1eea4ebd
UW
9889 return value_from_longest
9890 (type, ada_array_length (arg1, tem));
76a01679
JB
9891 }
9892 }
9893 else if (discrete_type_p (type_arg))
9894 {
9895 struct type *range_type;
0d5cff50 9896 const char *name = ada_type_name (type_arg);
5b4ee69b 9897
76a01679
JB
9898 range_type = NULL;
9899 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 9900 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
9901 if (range_type == NULL)
9902 range_type = type_arg;
9903 switch (op)
9904 {
9905 default:
323e0a4a 9906 error (_("unexpected attribute encountered"));
76a01679 9907 case OP_ATR_FIRST:
690cc4eb 9908 return value_from_longest
43bbcdc2 9909 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 9910 case OP_ATR_LAST:
690cc4eb 9911 return value_from_longest
43bbcdc2 9912 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 9913 case OP_ATR_LENGTH:
323e0a4a 9914 error (_("the 'length attribute applies only to array types"));
76a01679
JB
9915 }
9916 }
9917 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 9918 error (_("unimplemented type attribute"));
76a01679
JB
9919 else
9920 {
9921 LONGEST low, high;
9922
ad82864c
JB
9923 if (ada_is_constrained_packed_array_type (type_arg))
9924 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 9925
1eea4ebd 9926 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
76a01679 9927 if (type == NULL)
1eea4ebd
UW
9928 type = builtin_type (exp->gdbarch)->builtin_int;
9929
76a01679
JB
9930 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9931 return allocate_value (type);
9932
9933 switch (op)
9934 {
9935 default:
323e0a4a 9936 error (_("unexpected attribute encountered"));
76a01679 9937 case OP_ATR_FIRST:
1eea4ebd 9938 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
9939 return value_from_longest (type, low);
9940 case OP_ATR_LAST:
1eea4ebd 9941 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
9942 return value_from_longest (type, high);
9943 case OP_ATR_LENGTH:
1eea4ebd
UW
9944 low = ada_array_bound_from_type (type_arg, tem, 0);
9945 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
9946 return value_from_longest (type, high - low + 1);
9947 }
9948 }
14f9c5c9
AS
9949 }
9950
4c4b4cd2
PH
9951 case OP_ATR_TAG:
9952 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9953 if (noside == EVAL_SKIP)
76a01679 9954 goto nosideret;
4c4b4cd2
PH
9955
9956 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9957 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
9958
9959 return ada_value_tag (arg1);
9960
9961 case OP_ATR_MIN:
9962 case OP_ATR_MAX:
9963 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
9964 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9965 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9966 if (noside == EVAL_SKIP)
76a01679 9967 goto nosideret;
d2e4a39e 9968 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 9969 return value_zero (value_type (arg1), not_lval);
14f9c5c9 9970 else
f44316fa
UW
9971 {
9972 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9973 return value_binop (arg1, arg2,
9974 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
9975 }
14f9c5c9 9976
4c4b4cd2
PH
9977 case OP_ATR_MODULUS:
9978 {
31dedfee 9979 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 9980
5b4ee69b 9981 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
9982 if (noside == EVAL_SKIP)
9983 goto nosideret;
4c4b4cd2 9984
76a01679 9985 if (!ada_is_modular_type (type_arg))
323e0a4a 9986 error (_("'modulus must be applied to modular type"));
4c4b4cd2 9987
76a01679
JB
9988 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
9989 ada_modulus (type_arg));
4c4b4cd2
PH
9990 }
9991
9992
9993 case OP_ATR_POS:
9994 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
9995 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9996 if (noside == EVAL_SKIP)
76a01679 9997 goto nosideret;
3cb382c9
UW
9998 type = builtin_type (exp->gdbarch)->builtin_int;
9999 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10000 return value_zero (type, not_lval);
14f9c5c9 10001 else
3cb382c9 10002 return value_pos_atr (type, arg1);
14f9c5c9 10003
4c4b4cd2
PH
10004 case OP_ATR_SIZE:
10005 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
10006 type = value_type (arg1);
10007
10008 /* If the argument is a reference, then dereference its type, since
10009 the user is really asking for the size of the actual object,
10010 not the size of the pointer. */
10011 if (TYPE_CODE (type) == TYPE_CODE_REF)
10012 type = TYPE_TARGET_TYPE (type);
10013
4c4b4cd2 10014 if (noside == EVAL_SKIP)
76a01679 10015 goto nosideret;
4c4b4cd2 10016 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 10017 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 10018 else
22601c15 10019 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 10020 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
10021
10022 case OP_ATR_VAL:
10023 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 10024 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 10025 type = exp->elts[pc + 2].type;
14f9c5c9 10026 if (noside == EVAL_SKIP)
76a01679 10027 goto nosideret;
4c4b4cd2 10028 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10029 return value_zero (type, not_lval);
4c4b4cd2 10030 else
76a01679 10031 return value_val_atr (type, arg1);
4c4b4cd2
PH
10032
10033 case BINOP_EXP:
10034 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10035 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10036 if (noside == EVAL_SKIP)
10037 goto nosideret;
10038 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10039 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 10040 else
f44316fa
UW
10041 {
10042 /* For integer exponentiation operations,
10043 only promote the first argument. */
10044 if (is_integral_type (value_type (arg2)))
10045 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10046 else
10047 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10048
10049 return value_binop (arg1, arg2, op);
10050 }
4c4b4cd2
PH
10051
10052 case UNOP_PLUS:
10053 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10054 if (noside == EVAL_SKIP)
10055 goto nosideret;
10056 else
10057 return arg1;
10058
10059 case UNOP_ABS:
10060 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10061 if (noside == EVAL_SKIP)
10062 goto nosideret;
f44316fa 10063 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 10064 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 10065 return value_neg (arg1);
14f9c5c9 10066 else
4c4b4cd2 10067 return arg1;
14f9c5c9
AS
10068
10069 case UNOP_IND:
6b0d7253 10070 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10071 if (noside == EVAL_SKIP)
4c4b4cd2 10072 goto nosideret;
df407dfe 10073 type = ada_check_typedef (value_type (arg1));
14f9c5c9 10074 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
10075 {
10076 if (ada_is_array_descriptor_type (type))
10077 /* GDB allows dereferencing GNAT array descriptors. */
10078 {
10079 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 10080
4c4b4cd2 10081 if (arrType == NULL)
323e0a4a 10082 error (_("Attempt to dereference null array pointer."));
00a4c844 10083 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
10084 }
10085 else if (TYPE_CODE (type) == TYPE_CODE_PTR
10086 || TYPE_CODE (type) == TYPE_CODE_REF
10087 /* In C you can dereference an array to get the 1st elt. */
10088 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab
PH
10089 {
10090 type = to_static_fixed_type
10091 (ada_aligned_type
10092 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10093 check_size (type);
10094 return value_zero (type, lval_memory);
10095 }
4c4b4cd2 10096 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
10097 {
10098 /* GDB allows dereferencing an int. */
10099 if (expect_type == NULL)
10100 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10101 lval_memory);
10102 else
10103 {
10104 expect_type =
10105 to_static_fixed_type (ada_aligned_type (expect_type));
10106 return value_zero (expect_type, lval_memory);
10107 }
10108 }
4c4b4cd2 10109 else
323e0a4a 10110 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 10111 }
0963b4bd 10112 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 10113 type = ada_check_typedef (value_type (arg1));
d2e4a39e 10114
96967637
JB
10115 if (TYPE_CODE (type) == TYPE_CODE_INT)
10116 /* GDB allows dereferencing an int. If we were given
10117 the expect_type, then use that as the target type.
10118 Otherwise, assume that the target type is an int. */
10119 {
10120 if (expect_type != NULL)
10121 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10122 arg1));
10123 else
10124 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10125 (CORE_ADDR) value_as_address (arg1));
10126 }
6b0d7253 10127
4c4b4cd2
PH
10128 if (ada_is_array_descriptor_type (type))
10129 /* GDB allows dereferencing GNAT array descriptors. */
10130 return ada_coerce_to_simple_array (arg1);
14f9c5c9 10131 else
4c4b4cd2 10132 return ada_value_ind (arg1);
14f9c5c9
AS
10133
10134 case STRUCTOP_STRUCT:
10135 tem = longest_to_int (exp->elts[pc + 1].longconst);
10136 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
10137 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10138 if (noside == EVAL_SKIP)
4c4b4cd2 10139 goto nosideret;
14f9c5c9 10140 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10141 {
df407dfe 10142 struct type *type1 = value_type (arg1);
5b4ee69b 10143
76a01679
JB
10144 if (ada_is_tagged_type (type1, 1))
10145 {
10146 type = ada_lookup_struct_elt_type (type1,
10147 &exp->elts[pc + 2].string,
10148 1, 1, NULL);
10149 if (type == NULL)
10150 /* In this case, we assume that the field COULD exist
10151 in some extension of the type. Return an object of
10152 "type" void, which will match any formal
0963b4bd 10153 (see ada_type_match). */
30b15541
UW
10154 return value_zero (builtin_type (exp->gdbarch)->builtin_void,
10155 lval_memory);
76a01679
JB
10156 }
10157 else
10158 type =
10159 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
10160 0, NULL);
10161
10162 return value_zero (ada_aligned_type (type), lval_memory);
10163 }
14f9c5c9 10164 else
284614f0
JB
10165 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
10166 arg1 = unwrap_value (arg1);
10167 return ada_to_fixed_value (arg1);
10168
14f9c5c9 10169 case OP_TYPE:
4c4b4cd2
PH
10170 /* The value is not supposed to be used. This is here to make it
10171 easier to accommodate expressions that contain types. */
14f9c5c9
AS
10172 (*pos) += 2;
10173 if (noside == EVAL_SKIP)
4c4b4cd2 10174 goto nosideret;
14f9c5c9 10175 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 10176 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 10177 else
323e0a4a 10178 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
10179
10180 case OP_AGGREGATE:
10181 case OP_CHOICES:
10182 case OP_OTHERS:
10183 case OP_DISCRETE_RANGE:
10184 case OP_POSITIONAL:
10185 case OP_NAME:
10186 if (noside == EVAL_NORMAL)
10187 switch (op)
10188 {
10189 case OP_NAME:
10190 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 10191 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
10192 case OP_AGGREGATE:
10193 error (_("Aggregates only allowed on the right of an assignment"));
10194 default:
0963b4bd
MS
10195 internal_error (__FILE__, __LINE__,
10196 _("aggregate apparently mangled"));
52ce6436
PH
10197 }
10198
10199 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10200 *pos += oplen - 1;
10201 for (tem = 0; tem < nargs; tem += 1)
10202 ada_evaluate_subexp (NULL, exp, pos, noside);
10203 goto nosideret;
14f9c5c9
AS
10204 }
10205
10206nosideret:
22601c15 10207 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
14f9c5c9 10208}
14f9c5c9 10209\f
d2e4a39e 10210
4c4b4cd2 10211 /* Fixed point */
14f9c5c9
AS
10212
10213/* If TYPE encodes an Ada fixed-point type, return the suffix of the
10214 type name that encodes the 'small and 'delta information.
4c4b4cd2 10215 Otherwise, return NULL. */
14f9c5c9 10216
d2e4a39e 10217static const char *
ebf56fd3 10218fixed_type_info (struct type *type)
14f9c5c9 10219{
d2e4a39e 10220 const char *name = ada_type_name (type);
14f9c5c9
AS
10221 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
10222
d2e4a39e
AS
10223 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
10224 {
14f9c5c9 10225 const char *tail = strstr (name, "___XF_");
5b4ee69b 10226
14f9c5c9 10227 if (tail == NULL)
4c4b4cd2 10228 return NULL;
d2e4a39e 10229 else
4c4b4cd2 10230 return tail + 5;
14f9c5c9
AS
10231 }
10232 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
10233 return fixed_type_info (TYPE_TARGET_TYPE (type));
10234 else
10235 return NULL;
10236}
10237
4c4b4cd2 10238/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
10239
10240int
ebf56fd3 10241ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
10242{
10243 return fixed_type_info (type) != NULL;
10244}
10245
4c4b4cd2
PH
10246/* Return non-zero iff TYPE represents a System.Address type. */
10247
10248int
10249ada_is_system_address_type (struct type *type)
10250{
10251 return (TYPE_NAME (type)
10252 && strcmp (TYPE_NAME (type), "system__address") == 0);
10253}
10254
14f9c5c9
AS
10255/* Assuming that TYPE is the representation of an Ada fixed-point
10256 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 10257 delta cannot be determined. */
14f9c5c9
AS
10258
10259DOUBLEST
ebf56fd3 10260ada_delta (struct type *type)
14f9c5c9
AS
10261{
10262 const char *encoding = fixed_type_info (type);
facc390f 10263 DOUBLEST num, den;
14f9c5c9 10264
facc390f
JB
10265 /* Strictly speaking, num and den are encoded as integer. However,
10266 they may not fit into a long, and they will have to be converted
10267 to DOUBLEST anyway. So scan them as DOUBLEST. */
10268 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10269 &num, &den) < 2)
14f9c5c9 10270 return -1.0;
d2e4a39e 10271 else
facc390f 10272 return num / den;
14f9c5c9
AS
10273}
10274
10275/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 10276 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
10277
10278static DOUBLEST
ebf56fd3 10279scaling_factor (struct type *type)
14f9c5c9
AS
10280{
10281 const char *encoding = fixed_type_info (type);
facc390f 10282 DOUBLEST num0, den0, num1, den1;
14f9c5c9 10283 int n;
d2e4a39e 10284
facc390f
JB
10285 /* Strictly speaking, num's and den's are encoded as integer. However,
10286 they may not fit into a long, and they will have to be converted
10287 to DOUBLEST anyway. So scan them as DOUBLEST. */
10288 n = sscanf (encoding,
10289 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
10290 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10291 &num0, &den0, &num1, &den1);
14f9c5c9
AS
10292
10293 if (n < 2)
10294 return 1.0;
10295 else if (n == 4)
facc390f 10296 return num1 / den1;
d2e4a39e 10297 else
facc390f 10298 return num0 / den0;
14f9c5c9
AS
10299}
10300
10301
10302/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 10303 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
10304
10305DOUBLEST
ebf56fd3 10306ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 10307{
d2e4a39e 10308 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
10309}
10310
4c4b4cd2
PH
10311/* The representation of a fixed-point value of type TYPE
10312 corresponding to the value X. */
14f9c5c9
AS
10313
10314LONGEST
ebf56fd3 10315ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
10316{
10317 return (LONGEST) (x / scaling_factor (type) + 0.5);
10318}
10319
14f9c5c9 10320\f
d2e4a39e 10321
4c4b4cd2 10322 /* Range types */
14f9c5c9
AS
10323
10324/* Scan STR beginning at position K for a discriminant name, and
10325 return the value of that discriminant field of DVAL in *PX. If
10326 PNEW_K is not null, put the position of the character beyond the
10327 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 10328 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
10329
10330static int
07d8f827 10331scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
76a01679 10332 int *pnew_k)
14f9c5c9
AS
10333{
10334 static char *bound_buffer = NULL;
10335 static size_t bound_buffer_len = 0;
10336 char *bound;
10337 char *pend;
d2e4a39e 10338 struct value *bound_val;
14f9c5c9
AS
10339
10340 if (dval == NULL || str == NULL || str[k] == '\0')
10341 return 0;
10342
d2e4a39e 10343 pend = strstr (str + k, "__");
14f9c5c9
AS
10344 if (pend == NULL)
10345 {
d2e4a39e 10346 bound = str + k;
14f9c5c9
AS
10347 k += strlen (bound);
10348 }
d2e4a39e 10349 else
14f9c5c9 10350 {
d2e4a39e 10351 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
14f9c5c9 10352 bound = bound_buffer;
d2e4a39e
AS
10353 strncpy (bound_buffer, str + k, pend - (str + k));
10354 bound[pend - (str + k)] = '\0';
10355 k = pend - str;
14f9c5c9 10356 }
d2e4a39e 10357
df407dfe 10358 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
10359 if (bound_val == NULL)
10360 return 0;
10361
10362 *px = value_as_long (bound_val);
10363 if (pnew_k != NULL)
10364 *pnew_k = k;
10365 return 1;
10366}
10367
10368/* Value of variable named NAME in the current environment. If
10369 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
10370 otherwise causes an error with message ERR_MSG. */
10371
d2e4a39e
AS
10372static struct value *
10373get_var_value (char *name, char *err_msg)
14f9c5c9 10374{
4c4b4cd2 10375 struct ada_symbol_info *syms;
14f9c5c9
AS
10376 int nsyms;
10377
4c4b4cd2 10378 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
d9680e73 10379 &syms, 1);
14f9c5c9
AS
10380
10381 if (nsyms != 1)
10382 {
10383 if (err_msg == NULL)
4c4b4cd2 10384 return 0;
14f9c5c9 10385 else
8a3fe4f8 10386 error (("%s"), err_msg);
14f9c5c9
AS
10387 }
10388
4c4b4cd2 10389 return value_of_variable (syms[0].sym, syms[0].block);
14f9c5c9 10390}
d2e4a39e 10391
14f9c5c9 10392/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
10393 no such variable found, returns 0, and sets *FLAG to 0. If
10394 successful, sets *FLAG to 1. */
10395
14f9c5c9 10396LONGEST
4c4b4cd2 10397get_int_var_value (char *name, int *flag)
14f9c5c9 10398{
4c4b4cd2 10399 struct value *var_val = get_var_value (name, 0);
d2e4a39e 10400
14f9c5c9
AS
10401 if (var_val == 0)
10402 {
10403 if (flag != NULL)
4c4b4cd2 10404 *flag = 0;
14f9c5c9
AS
10405 return 0;
10406 }
10407 else
10408 {
10409 if (flag != NULL)
4c4b4cd2 10410 *flag = 1;
14f9c5c9
AS
10411 return value_as_long (var_val);
10412 }
10413}
d2e4a39e 10414
14f9c5c9
AS
10415
10416/* Return a range type whose base type is that of the range type named
10417 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 10418 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
10419 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
10420 corresponding range type from debug information; fall back to using it
10421 if symbol lookup fails. If a new type must be created, allocate it
10422 like ORIG_TYPE was. The bounds information, in general, is encoded
10423 in NAME, the base type given in the named range type. */
14f9c5c9 10424
d2e4a39e 10425static struct type *
28c85d6c 10426to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 10427{
0d5cff50 10428 const char *name;
14f9c5c9 10429 struct type *base_type;
d2e4a39e 10430 char *subtype_info;
14f9c5c9 10431
28c85d6c
JB
10432 gdb_assert (raw_type != NULL);
10433 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 10434
1ce677a4 10435 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
10436 base_type = TYPE_TARGET_TYPE (raw_type);
10437 else
10438 base_type = raw_type;
10439
28c85d6c 10440 name = TYPE_NAME (raw_type);
14f9c5c9
AS
10441 subtype_info = strstr (name, "___XD");
10442 if (subtype_info == NULL)
690cc4eb 10443 {
43bbcdc2
PH
10444 LONGEST L = ada_discrete_type_low_bound (raw_type);
10445 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 10446
690cc4eb
PH
10447 if (L < INT_MIN || U > INT_MAX)
10448 return raw_type;
10449 else
28c85d6c 10450 return create_range_type (alloc_type_copy (raw_type), raw_type,
43bbcdc2
PH
10451 ada_discrete_type_low_bound (raw_type),
10452 ada_discrete_type_high_bound (raw_type));
690cc4eb 10453 }
14f9c5c9
AS
10454 else
10455 {
10456 static char *name_buf = NULL;
10457 static size_t name_len = 0;
10458 int prefix_len = subtype_info - name;
10459 LONGEST L, U;
10460 struct type *type;
10461 char *bounds_str;
10462 int n;
10463
10464 GROW_VECT (name_buf, name_len, prefix_len + 5);
10465 strncpy (name_buf, name, prefix_len);
10466 name_buf[prefix_len] = '\0';
10467
10468 subtype_info += 5;
10469 bounds_str = strchr (subtype_info, '_');
10470 n = 1;
10471
d2e4a39e 10472 if (*subtype_info == 'L')
4c4b4cd2
PH
10473 {
10474 if (!ada_scan_number (bounds_str, n, &L, &n)
10475 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
10476 return raw_type;
10477 if (bounds_str[n] == '_')
10478 n += 2;
0963b4bd 10479 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
10480 n += 1;
10481 subtype_info += 1;
10482 }
d2e4a39e 10483 else
4c4b4cd2
PH
10484 {
10485 int ok;
5b4ee69b 10486
4c4b4cd2
PH
10487 strcpy (name_buf + prefix_len, "___L");
10488 L = get_int_var_value (name_buf, &ok);
10489 if (!ok)
10490 {
323e0a4a 10491 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
10492 L = 1;
10493 }
10494 }
14f9c5c9 10495
d2e4a39e 10496 if (*subtype_info == 'U')
4c4b4cd2
PH
10497 {
10498 if (!ada_scan_number (bounds_str, n, &U, &n)
10499 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
10500 return raw_type;
10501 }
d2e4a39e 10502 else
4c4b4cd2
PH
10503 {
10504 int ok;
5b4ee69b 10505
4c4b4cd2
PH
10506 strcpy (name_buf + prefix_len, "___U");
10507 U = get_int_var_value (name_buf, &ok);
10508 if (!ok)
10509 {
323e0a4a 10510 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
10511 U = L;
10512 }
10513 }
14f9c5c9 10514
28c85d6c 10515 type = create_range_type (alloc_type_copy (raw_type), base_type, L, U);
d2e4a39e 10516 TYPE_NAME (type) = name;
14f9c5c9
AS
10517 return type;
10518 }
10519}
10520
4c4b4cd2
PH
10521/* True iff NAME is the name of a range type. */
10522
14f9c5c9 10523int
d2e4a39e 10524ada_is_range_type_name (const char *name)
14f9c5c9
AS
10525{
10526 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 10527}
14f9c5c9 10528\f
d2e4a39e 10529
4c4b4cd2
PH
10530 /* Modular types */
10531
10532/* True iff TYPE is an Ada modular type. */
14f9c5c9 10533
14f9c5c9 10534int
d2e4a39e 10535ada_is_modular_type (struct type *type)
14f9c5c9 10536{
18af8284 10537 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
10538
10539 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 10540 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 10541 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
10542}
10543
0056e4d5
JB
10544/* Try to determine the lower and upper bounds of the given modular type
10545 using the type name only. Return non-zero and set L and U as the lower
10546 and upper bounds (respectively) if successful. */
10547
10548int
10549ada_modulus_from_name (struct type *type, ULONGEST *modulus)
10550{
0d5cff50
DE
10551 const char *name = ada_type_name (type);
10552 const char *suffix;
0056e4d5
JB
10553 int k;
10554 LONGEST U;
10555
10556 if (name == NULL)
10557 return 0;
10558
10559 /* Discrete type bounds are encoded using an __XD suffix. In our case,
10560 we are looking for static bounds, which means an __XDLU suffix.
10561 Moreover, we know that the lower bound of modular types is always
10562 zero, so the actual suffix should start with "__XDLU_0__", and
10563 then be followed by the upper bound value. */
10564 suffix = strstr (name, "__XDLU_0__");
10565 if (suffix == NULL)
10566 return 0;
10567 k = 10;
10568 if (!ada_scan_number (suffix, k, &U, NULL))
10569 return 0;
10570
10571 *modulus = (ULONGEST) U + 1;
10572 return 1;
10573}
10574
4c4b4cd2
PH
10575/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
10576
61ee279c 10577ULONGEST
0056e4d5 10578ada_modulus (struct type *type)
14f9c5c9 10579{
43bbcdc2 10580 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 10581}
d2e4a39e 10582\f
f7f9143b
JB
10583
10584/* Ada exception catchpoint support:
10585 ---------------------------------
10586
10587 We support 3 kinds of exception catchpoints:
10588 . catchpoints on Ada exceptions
10589 . catchpoints on unhandled Ada exceptions
10590 . catchpoints on failed assertions
10591
10592 Exceptions raised during failed assertions, or unhandled exceptions
10593 could perfectly be caught with the general catchpoint on Ada exceptions.
10594 However, we can easily differentiate these two special cases, and having
10595 the option to distinguish these two cases from the rest can be useful
10596 to zero-in on certain situations.
10597
10598 Exception catchpoints are a specialized form of breakpoint,
10599 since they rely on inserting breakpoints inside known routines
10600 of the GNAT runtime. The implementation therefore uses a standard
10601 breakpoint structure of the BP_BREAKPOINT type, but with its own set
10602 of breakpoint_ops.
10603
0259addd
JB
10604 Support in the runtime for exception catchpoints have been changed
10605 a few times already, and these changes affect the implementation
10606 of these catchpoints. In order to be able to support several
10607 variants of the runtime, we use a sniffer that will determine
28010a5d 10608 the runtime variant used by the program being debugged. */
f7f9143b
JB
10609
10610/* The different types of catchpoints that we introduced for catching
10611 Ada exceptions. */
10612
10613enum exception_catchpoint_kind
10614{
10615 ex_catch_exception,
10616 ex_catch_exception_unhandled,
10617 ex_catch_assert
10618};
10619
3d0b0fa3
JB
10620/* Ada's standard exceptions. */
10621
10622static char *standard_exc[] = {
10623 "constraint_error",
10624 "program_error",
10625 "storage_error",
10626 "tasking_error"
10627};
10628
0259addd
JB
10629typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
10630
10631/* A structure that describes how to support exception catchpoints
10632 for a given executable. */
10633
10634struct exception_support_info
10635{
10636 /* The name of the symbol to break on in order to insert
10637 a catchpoint on exceptions. */
10638 const char *catch_exception_sym;
10639
10640 /* The name of the symbol to break on in order to insert
10641 a catchpoint on unhandled exceptions. */
10642 const char *catch_exception_unhandled_sym;
10643
10644 /* The name of the symbol to break on in order to insert
10645 a catchpoint on failed assertions. */
10646 const char *catch_assert_sym;
10647
10648 /* Assuming that the inferior just triggered an unhandled exception
10649 catchpoint, this function is responsible for returning the address
10650 in inferior memory where the name of that exception is stored.
10651 Return zero if the address could not be computed. */
10652 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
10653};
10654
10655static CORE_ADDR ada_unhandled_exception_name_addr (void);
10656static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
10657
10658/* The following exception support info structure describes how to
10659 implement exception catchpoints with the latest version of the
10660 Ada runtime (as of 2007-03-06). */
10661
10662static const struct exception_support_info default_exception_support_info =
10663{
10664 "__gnat_debug_raise_exception", /* catch_exception_sym */
10665 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
10666 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
10667 ada_unhandled_exception_name_addr
10668};
10669
10670/* The following exception support info structure describes how to
10671 implement exception catchpoints with a slightly older version
10672 of the Ada runtime. */
10673
10674static const struct exception_support_info exception_support_info_fallback =
10675{
10676 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
10677 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
10678 "system__assertions__raise_assert_failure", /* catch_assert_sym */
10679 ada_unhandled_exception_name_addr_from_raise
10680};
10681
f17011e0
JB
10682/* Return nonzero if we can detect the exception support routines
10683 described in EINFO.
10684
10685 This function errors out if an abnormal situation is detected
10686 (for instance, if we find the exception support routines, but
10687 that support is found to be incomplete). */
10688
10689static int
10690ada_has_this_exception_support (const struct exception_support_info *einfo)
10691{
10692 struct symbol *sym;
10693
10694 /* The symbol we're looking up is provided by a unit in the GNAT runtime
10695 that should be compiled with debugging information. As a result, we
10696 expect to find that symbol in the symtabs. */
10697
10698 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
10699 if (sym == NULL)
a6af7abe
JB
10700 {
10701 /* Perhaps we did not find our symbol because the Ada runtime was
10702 compiled without debugging info, or simply stripped of it.
10703 It happens on some GNU/Linux distributions for instance, where
10704 users have to install a separate debug package in order to get
10705 the runtime's debugging info. In that situation, let the user
10706 know why we cannot insert an Ada exception catchpoint.
10707
10708 Note: Just for the purpose of inserting our Ada exception
10709 catchpoint, we could rely purely on the associated minimal symbol.
10710 But we would be operating in degraded mode anyway, since we are
10711 still lacking the debugging info needed later on to extract
10712 the name of the exception being raised (this name is printed in
10713 the catchpoint message, and is also used when trying to catch
10714 a specific exception). We do not handle this case for now. */
10715 if (lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL))
10716 error (_("Your Ada runtime appears to be missing some debugging "
10717 "information.\nCannot insert Ada exception catchpoint "
10718 "in this configuration."));
10719
10720 return 0;
10721 }
f17011e0
JB
10722
10723 /* Make sure that the symbol we found corresponds to a function. */
10724
10725 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
10726 error (_("Symbol \"%s\" is not a function (class = %d)"),
10727 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
10728
10729 return 1;
10730}
10731
0259addd
JB
10732/* Inspect the Ada runtime and determine which exception info structure
10733 should be used to provide support for exception catchpoints.
10734
3eecfa55
JB
10735 This function will always set the per-inferior exception_info,
10736 or raise an error. */
0259addd
JB
10737
10738static void
10739ada_exception_support_info_sniffer (void)
10740{
3eecfa55 10741 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
10742 struct symbol *sym;
10743
10744 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 10745 if (data->exception_info != NULL)
0259addd
JB
10746 return;
10747
10748 /* Check the latest (default) exception support info. */
f17011e0 10749 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 10750 {
3eecfa55 10751 data->exception_info = &default_exception_support_info;
0259addd
JB
10752 return;
10753 }
10754
10755 /* Try our fallback exception suport info. */
f17011e0 10756 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 10757 {
3eecfa55 10758 data->exception_info = &exception_support_info_fallback;
0259addd
JB
10759 return;
10760 }
10761
10762 /* Sometimes, it is normal for us to not be able to find the routine
10763 we are looking for. This happens when the program is linked with
10764 the shared version of the GNAT runtime, and the program has not been
10765 started yet. Inform the user of these two possible causes if
10766 applicable. */
10767
ccefe4c4 10768 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
10769 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
10770
10771 /* If the symbol does not exist, then check that the program is
10772 already started, to make sure that shared libraries have been
10773 loaded. If it is not started, this may mean that the symbol is
10774 in a shared library. */
10775
10776 if (ptid_get_pid (inferior_ptid) == 0)
10777 error (_("Unable to insert catchpoint. Try to start the program first."));
10778
10779 /* At this point, we know that we are debugging an Ada program and
10780 that the inferior has been started, but we still are not able to
0963b4bd 10781 find the run-time symbols. That can mean that we are in
0259addd
JB
10782 configurable run time mode, or that a-except as been optimized
10783 out by the linker... In any case, at this point it is not worth
10784 supporting this feature. */
10785
7dda8cff 10786 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
10787}
10788
f7f9143b
JB
10789/* True iff FRAME is very likely to be that of a function that is
10790 part of the runtime system. This is all very heuristic, but is
10791 intended to be used as advice as to what frames are uninteresting
10792 to most users. */
10793
10794static int
10795is_known_support_routine (struct frame_info *frame)
10796{
4ed6b5be 10797 struct symtab_and_line sal;
0d5cff50 10798 const char *func_name;
692465f1 10799 enum language func_lang;
f7f9143b 10800 int i;
f7f9143b 10801
4ed6b5be
JB
10802 /* If this code does not have any debugging information (no symtab),
10803 This cannot be any user code. */
f7f9143b 10804
4ed6b5be 10805 find_frame_sal (frame, &sal);
f7f9143b
JB
10806 if (sal.symtab == NULL)
10807 return 1;
10808
4ed6b5be
JB
10809 /* If there is a symtab, but the associated source file cannot be
10810 located, then assume this is not user code: Selecting a frame
10811 for which we cannot display the code would not be very helpful
10812 for the user. This should also take care of case such as VxWorks
10813 where the kernel has some debugging info provided for a few units. */
f7f9143b 10814
9bbc9174 10815 if (symtab_to_fullname (sal.symtab) == NULL)
f7f9143b
JB
10816 return 1;
10817
4ed6b5be
JB
10818 /* Check the unit filename againt the Ada runtime file naming.
10819 We also check the name of the objfile against the name of some
10820 known system libraries that sometimes come with debugging info
10821 too. */
10822
f7f9143b
JB
10823 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
10824 {
10825 re_comp (known_runtime_file_name_patterns[i]);
10826 if (re_exec (sal.symtab->filename))
10827 return 1;
4ed6b5be
JB
10828 if (sal.symtab->objfile != NULL
10829 && re_exec (sal.symtab->objfile->name))
10830 return 1;
f7f9143b
JB
10831 }
10832
4ed6b5be 10833 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 10834
e9e07ba6 10835 find_frame_funname (frame, &func_name, &func_lang, NULL);
f7f9143b
JB
10836 if (func_name == NULL)
10837 return 1;
10838
10839 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
10840 {
10841 re_comp (known_auxiliary_function_name_patterns[i]);
10842 if (re_exec (func_name))
10843 return 1;
10844 }
10845
10846 return 0;
10847}
10848
10849/* Find the first frame that contains debugging information and that is not
10850 part of the Ada run-time, starting from FI and moving upward. */
10851
0ef643c8 10852void
f7f9143b
JB
10853ada_find_printable_frame (struct frame_info *fi)
10854{
10855 for (; fi != NULL; fi = get_prev_frame (fi))
10856 {
10857 if (!is_known_support_routine (fi))
10858 {
10859 select_frame (fi);
10860 break;
10861 }
10862 }
10863
10864}
10865
10866/* Assuming that the inferior just triggered an unhandled exception
10867 catchpoint, return the address in inferior memory where the name
10868 of the exception is stored.
10869
10870 Return zero if the address could not be computed. */
10871
10872static CORE_ADDR
10873ada_unhandled_exception_name_addr (void)
0259addd
JB
10874{
10875 return parse_and_eval_address ("e.full_name");
10876}
10877
10878/* Same as ada_unhandled_exception_name_addr, except that this function
10879 should be used when the inferior uses an older version of the runtime,
10880 where the exception name needs to be extracted from a specific frame
10881 several frames up in the callstack. */
10882
10883static CORE_ADDR
10884ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
10885{
10886 int frame_level;
10887 struct frame_info *fi;
3eecfa55 10888 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
f7f9143b
JB
10889
10890 /* To determine the name of this exception, we need to select
10891 the frame corresponding to RAISE_SYM_NAME. This frame is
10892 at least 3 levels up, so we simply skip the first 3 frames
10893 without checking the name of their associated function. */
10894 fi = get_current_frame ();
10895 for (frame_level = 0; frame_level < 3; frame_level += 1)
10896 if (fi != NULL)
10897 fi = get_prev_frame (fi);
10898
10899 while (fi != NULL)
10900 {
0d5cff50 10901 const char *func_name;
692465f1
JB
10902 enum language func_lang;
10903
e9e07ba6 10904 find_frame_funname (fi, &func_name, &func_lang, NULL);
f7f9143b 10905 if (func_name != NULL
3eecfa55 10906 && strcmp (func_name, data->exception_info->catch_exception_sym) == 0)
f7f9143b
JB
10907 break; /* We found the frame we were looking for... */
10908 fi = get_prev_frame (fi);
10909 }
10910
10911 if (fi == NULL)
10912 return 0;
10913
10914 select_frame (fi);
10915 return parse_and_eval_address ("id.full_name");
10916}
10917
10918/* Assuming the inferior just triggered an Ada exception catchpoint
10919 (of any type), return the address in inferior memory where the name
10920 of the exception is stored, if applicable.
10921
10922 Return zero if the address could not be computed, or if not relevant. */
10923
10924static CORE_ADDR
10925ada_exception_name_addr_1 (enum exception_catchpoint_kind ex,
10926 struct breakpoint *b)
10927{
3eecfa55
JB
10928 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
10929
f7f9143b
JB
10930 switch (ex)
10931 {
10932 case ex_catch_exception:
10933 return (parse_and_eval_address ("e.full_name"));
10934 break;
10935
10936 case ex_catch_exception_unhandled:
3eecfa55 10937 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
10938 break;
10939
10940 case ex_catch_assert:
10941 return 0; /* Exception name is not relevant in this case. */
10942 break;
10943
10944 default:
10945 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10946 break;
10947 }
10948
10949 return 0; /* Should never be reached. */
10950}
10951
10952/* Same as ada_exception_name_addr_1, except that it intercepts and contains
10953 any error that ada_exception_name_addr_1 might cause to be thrown.
10954 When an error is intercepted, a warning with the error message is printed,
10955 and zero is returned. */
10956
10957static CORE_ADDR
10958ada_exception_name_addr (enum exception_catchpoint_kind ex,
10959 struct breakpoint *b)
10960{
bfd189b1 10961 volatile struct gdb_exception e;
f7f9143b
JB
10962 CORE_ADDR result = 0;
10963
10964 TRY_CATCH (e, RETURN_MASK_ERROR)
10965 {
10966 result = ada_exception_name_addr_1 (ex, b);
10967 }
10968
10969 if (e.reason < 0)
10970 {
10971 warning (_("failed to get exception name: %s"), e.message);
10972 return 0;
10973 }
10974
10975 return result;
10976}
10977
28010a5d
PA
10978static struct symtab_and_line ada_exception_sal (enum exception_catchpoint_kind,
10979 char *, char **,
c0a91b2b 10980 const struct breakpoint_ops **);
28010a5d
PA
10981static char *ada_exception_catchpoint_cond_string (const char *excep_string);
10982
10983/* Ada catchpoints.
10984
10985 In the case of catchpoints on Ada exceptions, the catchpoint will
10986 stop the target on every exception the program throws. When a user
10987 specifies the name of a specific exception, we translate this
10988 request into a condition expression (in text form), and then parse
10989 it into an expression stored in each of the catchpoint's locations.
10990 We then use this condition to check whether the exception that was
10991 raised is the one the user is interested in. If not, then the
10992 target is resumed again. We store the name of the requested
10993 exception, in order to be able to re-set the condition expression
10994 when symbols change. */
10995
10996/* An instance of this type is used to represent an Ada catchpoint
10997 breakpoint location. It includes a "struct bp_location" as a kind
10998 of base class; users downcast to "struct bp_location *" when
10999 needed. */
11000
11001struct ada_catchpoint_location
11002{
11003 /* The base class. */
11004 struct bp_location base;
11005
11006 /* The condition that checks whether the exception that was raised
11007 is the specific exception the user specified on catchpoint
11008 creation. */
11009 struct expression *excep_cond_expr;
11010};
11011
11012/* Implement the DTOR method in the bp_location_ops structure for all
11013 Ada exception catchpoint kinds. */
11014
11015static void
11016ada_catchpoint_location_dtor (struct bp_location *bl)
11017{
11018 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
11019
11020 xfree (al->excep_cond_expr);
11021}
11022
11023/* The vtable to be used in Ada catchpoint locations. */
11024
11025static const struct bp_location_ops ada_catchpoint_location_ops =
11026{
11027 ada_catchpoint_location_dtor
11028};
11029
11030/* An instance of this type is used to represent an Ada catchpoint.
11031 It includes a "struct breakpoint" as a kind of base class; users
11032 downcast to "struct breakpoint *" when needed. */
11033
11034struct ada_catchpoint
11035{
11036 /* The base class. */
11037 struct breakpoint base;
11038
11039 /* The name of the specific exception the user specified. */
11040 char *excep_string;
11041};
11042
11043/* Parse the exception condition string in the context of each of the
11044 catchpoint's locations, and store them for later evaluation. */
11045
11046static void
11047create_excep_cond_exprs (struct ada_catchpoint *c)
11048{
11049 struct cleanup *old_chain;
11050 struct bp_location *bl;
11051 char *cond_string;
11052
11053 /* Nothing to do if there's no specific exception to catch. */
11054 if (c->excep_string == NULL)
11055 return;
11056
11057 /* Same if there are no locations... */
11058 if (c->base.loc == NULL)
11059 return;
11060
11061 /* Compute the condition expression in text form, from the specific
11062 expection we want to catch. */
11063 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
11064 old_chain = make_cleanup (xfree, cond_string);
11065
11066 /* Iterate over all the catchpoint's locations, and parse an
11067 expression for each. */
11068 for (bl = c->base.loc; bl != NULL; bl = bl->next)
11069 {
11070 struct ada_catchpoint_location *ada_loc
11071 = (struct ada_catchpoint_location *) bl;
11072 struct expression *exp = NULL;
11073
11074 if (!bl->shlib_disabled)
11075 {
11076 volatile struct gdb_exception e;
11077 char *s;
11078
11079 s = cond_string;
11080 TRY_CATCH (e, RETURN_MASK_ERROR)
11081 {
11082 exp = parse_exp_1 (&s, block_for_pc (bl->address), 0);
11083 }
11084 if (e.reason < 0)
11085 warning (_("failed to reevaluate internal exception condition "
11086 "for catchpoint %d: %s"),
11087 c->base.number, e.message);
11088 }
11089
11090 ada_loc->excep_cond_expr = exp;
11091 }
11092
11093 do_cleanups (old_chain);
11094}
11095
11096/* Implement the DTOR method in the breakpoint_ops structure for all
11097 exception catchpoint kinds. */
11098
11099static void
11100dtor_exception (enum exception_catchpoint_kind ex, struct breakpoint *b)
11101{
11102 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11103
11104 xfree (c->excep_string);
348d480f 11105
2060206e 11106 bkpt_breakpoint_ops.dtor (b);
28010a5d
PA
11107}
11108
11109/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11110 structure for all exception catchpoint kinds. */
11111
11112static struct bp_location *
11113allocate_location_exception (enum exception_catchpoint_kind ex,
11114 struct breakpoint *self)
11115{
11116 struct ada_catchpoint_location *loc;
11117
11118 loc = XNEW (struct ada_catchpoint_location);
11119 init_bp_location (&loc->base, &ada_catchpoint_location_ops, self);
11120 loc->excep_cond_expr = NULL;
11121 return &loc->base;
11122}
11123
11124/* Implement the RE_SET method in the breakpoint_ops structure for all
11125 exception catchpoint kinds. */
11126
11127static void
11128re_set_exception (enum exception_catchpoint_kind ex, struct breakpoint *b)
11129{
11130 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11131
11132 /* Call the base class's method. This updates the catchpoint's
11133 locations. */
2060206e 11134 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
11135
11136 /* Reparse the exception conditional expressions. One for each
11137 location. */
11138 create_excep_cond_exprs (c);
11139}
11140
11141/* Returns true if we should stop for this breakpoint hit. If the
11142 user specified a specific exception, we only want to cause a stop
11143 if the program thrown that exception. */
11144
11145static int
11146should_stop_exception (const struct bp_location *bl)
11147{
11148 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11149 const struct ada_catchpoint_location *ada_loc
11150 = (const struct ada_catchpoint_location *) bl;
11151 volatile struct gdb_exception ex;
11152 int stop;
11153
11154 /* With no specific exception, should always stop. */
11155 if (c->excep_string == NULL)
11156 return 1;
11157
11158 if (ada_loc->excep_cond_expr == NULL)
11159 {
11160 /* We will have a NULL expression if back when we were creating
11161 the expressions, this location's had failed to parse. */
11162 return 1;
11163 }
11164
11165 stop = 1;
11166 TRY_CATCH (ex, RETURN_MASK_ALL)
11167 {
11168 struct value *mark;
11169
11170 mark = value_mark ();
11171 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr));
11172 value_free_to_mark (mark);
11173 }
11174 if (ex.reason < 0)
11175 exception_fprintf (gdb_stderr, ex,
11176 _("Error in testing exception condition:\n"));
11177 return stop;
11178}
11179
11180/* Implement the CHECK_STATUS method in the breakpoint_ops structure
11181 for all exception catchpoint kinds. */
11182
11183static void
11184check_status_exception (enum exception_catchpoint_kind ex, bpstat bs)
11185{
11186 bs->stop = should_stop_exception (bs->bp_location_at);
11187}
11188
f7f9143b
JB
11189/* Implement the PRINT_IT method in the breakpoint_ops structure
11190 for all exception catchpoint kinds. */
11191
11192static enum print_stop_action
348d480f 11193print_it_exception (enum exception_catchpoint_kind ex, bpstat bs)
f7f9143b 11194{
79a45e25 11195 struct ui_out *uiout = current_uiout;
348d480f
PA
11196 struct breakpoint *b = bs->breakpoint_at;
11197
956a9fb9 11198 annotate_catchpoint (b->number);
f7f9143b 11199
956a9fb9 11200 if (ui_out_is_mi_like_p (uiout))
f7f9143b 11201 {
956a9fb9
JB
11202 ui_out_field_string (uiout, "reason",
11203 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11204 ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition));
f7f9143b
JB
11205 }
11206
00eb2c4a
JB
11207 ui_out_text (uiout,
11208 b->disposition == disp_del ? "\nTemporary catchpoint "
11209 : "\nCatchpoint ");
956a9fb9
JB
11210 ui_out_field_int (uiout, "bkptno", b->number);
11211 ui_out_text (uiout, ", ");
f7f9143b 11212
f7f9143b
JB
11213 switch (ex)
11214 {
11215 case ex_catch_exception:
f7f9143b 11216 case ex_catch_exception_unhandled:
956a9fb9
JB
11217 {
11218 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
11219 char exception_name[256];
11220
11221 if (addr != 0)
11222 {
11223 read_memory (addr, exception_name, sizeof (exception_name) - 1);
11224 exception_name [sizeof (exception_name) - 1] = '\0';
11225 }
11226 else
11227 {
11228 /* For some reason, we were unable to read the exception
11229 name. This could happen if the Runtime was compiled
11230 without debugging info, for instance. In that case,
11231 just replace the exception name by the generic string
11232 "exception" - it will read as "an exception" in the
11233 notification we are about to print. */
967cff16 11234 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
11235 }
11236 /* In the case of unhandled exception breakpoints, we print
11237 the exception name as "unhandled EXCEPTION_NAME", to make
11238 it clearer to the user which kind of catchpoint just got
11239 hit. We used ui_out_text to make sure that this extra
11240 info does not pollute the exception name in the MI case. */
11241 if (ex == ex_catch_exception_unhandled)
11242 ui_out_text (uiout, "unhandled ");
11243 ui_out_field_string (uiout, "exception-name", exception_name);
11244 }
11245 break;
f7f9143b 11246 case ex_catch_assert:
956a9fb9
JB
11247 /* In this case, the name of the exception is not really
11248 important. Just print "failed assertion" to make it clearer
11249 that his program just hit an assertion-failure catchpoint.
11250 We used ui_out_text because this info does not belong in
11251 the MI output. */
11252 ui_out_text (uiout, "failed assertion");
11253 break;
f7f9143b 11254 }
956a9fb9
JB
11255 ui_out_text (uiout, " at ");
11256 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
11257
11258 return PRINT_SRC_AND_LOC;
11259}
11260
11261/* Implement the PRINT_ONE method in the breakpoint_ops structure
11262 for all exception catchpoint kinds. */
11263
11264static void
11265print_one_exception (enum exception_catchpoint_kind ex,
a6d9a66e 11266 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11267{
79a45e25 11268 struct ui_out *uiout = current_uiout;
28010a5d 11269 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
11270 struct value_print_options opts;
11271
11272 get_user_print_options (&opts);
11273 if (opts.addressprint)
f7f9143b
JB
11274 {
11275 annotate_field (4);
5af949e3 11276 ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
11277 }
11278
11279 annotate_field (5);
a6d9a66e 11280 *last_loc = b->loc;
f7f9143b
JB
11281 switch (ex)
11282 {
11283 case ex_catch_exception:
28010a5d 11284 if (c->excep_string != NULL)
f7f9143b 11285 {
28010a5d
PA
11286 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11287
f7f9143b
JB
11288 ui_out_field_string (uiout, "what", msg);
11289 xfree (msg);
11290 }
11291 else
11292 ui_out_field_string (uiout, "what", "all Ada exceptions");
11293
11294 break;
11295
11296 case ex_catch_exception_unhandled:
11297 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
11298 break;
11299
11300 case ex_catch_assert:
11301 ui_out_field_string (uiout, "what", "failed Ada assertions");
11302 break;
11303
11304 default:
11305 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11306 break;
11307 }
11308}
11309
11310/* Implement the PRINT_MENTION method in the breakpoint_ops structure
11311 for all exception catchpoint kinds. */
11312
11313static void
11314print_mention_exception (enum exception_catchpoint_kind ex,
11315 struct breakpoint *b)
11316{
28010a5d 11317 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 11318 struct ui_out *uiout = current_uiout;
28010a5d 11319
00eb2c4a
JB
11320 ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ")
11321 : _("Catchpoint "));
11322 ui_out_field_int (uiout, "bkptno", b->number);
11323 ui_out_text (uiout, ": ");
11324
f7f9143b
JB
11325 switch (ex)
11326 {
11327 case ex_catch_exception:
28010a5d 11328 if (c->excep_string != NULL)
00eb2c4a
JB
11329 {
11330 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11331 struct cleanup *old_chain = make_cleanup (xfree, info);
11332
11333 ui_out_text (uiout, info);
11334 do_cleanups (old_chain);
11335 }
f7f9143b 11336 else
00eb2c4a 11337 ui_out_text (uiout, _("all Ada exceptions"));
f7f9143b
JB
11338 break;
11339
11340 case ex_catch_exception_unhandled:
00eb2c4a 11341 ui_out_text (uiout, _("unhandled Ada exceptions"));
f7f9143b
JB
11342 break;
11343
11344 case ex_catch_assert:
00eb2c4a 11345 ui_out_text (uiout, _("failed Ada assertions"));
f7f9143b
JB
11346 break;
11347
11348 default:
11349 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11350 break;
11351 }
11352}
11353
6149aea9
PA
11354/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
11355 for all exception catchpoint kinds. */
11356
11357static void
11358print_recreate_exception (enum exception_catchpoint_kind ex,
11359 struct breakpoint *b, struct ui_file *fp)
11360{
28010a5d
PA
11361 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11362
6149aea9
PA
11363 switch (ex)
11364 {
11365 case ex_catch_exception:
11366 fprintf_filtered (fp, "catch exception");
28010a5d
PA
11367 if (c->excep_string != NULL)
11368 fprintf_filtered (fp, " %s", c->excep_string);
6149aea9
PA
11369 break;
11370
11371 case ex_catch_exception_unhandled:
78076abc 11372 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
11373 break;
11374
11375 case ex_catch_assert:
11376 fprintf_filtered (fp, "catch assert");
11377 break;
11378
11379 default:
11380 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11381 }
d9b3f62e 11382 print_recreate_thread (b, fp);
6149aea9
PA
11383}
11384
f7f9143b
JB
11385/* Virtual table for "catch exception" breakpoints. */
11386
28010a5d
PA
11387static void
11388dtor_catch_exception (struct breakpoint *b)
11389{
11390 dtor_exception (ex_catch_exception, b);
11391}
11392
11393static struct bp_location *
11394allocate_location_catch_exception (struct breakpoint *self)
11395{
11396 return allocate_location_exception (ex_catch_exception, self);
11397}
11398
11399static void
11400re_set_catch_exception (struct breakpoint *b)
11401{
11402 re_set_exception (ex_catch_exception, b);
11403}
11404
11405static void
11406check_status_catch_exception (bpstat bs)
11407{
11408 check_status_exception (ex_catch_exception, bs);
11409}
11410
f7f9143b 11411static enum print_stop_action
348d480f 11412print_it_catch_exception (bpstat bs)
f7f9143b 11413{
348d480f 11414 return print_it_exception (ex_catch_exception, bs);
f7f9143b
JB
11415}
11416
11417static void
a6d9a66e 11418print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11419{
a6d9a66e 11420 print_one_exception (ex_catch_exception, b, last_loc);
f7f9143b
JB
11421}
11422
11423static void
11424print_mention_catch_exception (struct breakpoint *b)
11425{
11426 print_mention_exception (ex_catch_exception, b);
11427}
11428
6149aea9
PA
11429static void
11430print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
11431{
11432 print_recreate_exception (ex_catch_exception, b, fp);
11433}
11434
2060206e 11435static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
11436
11437/* Virtual table for "catch exception unhandled" breakpoints. */
11438
28010a5d
PA
11439static void
11440dtor_catch_exception_unhandled (struct breakpoint *b)
11441{
11442 dtor_exception (ex_catch_exception_unhandled, b);
11443}
11444
11445static struct bp_location *
11446allocate_location_catch_exception_unhandled (struct breakpoint *self)
11447{
11448 return allocate_location_exception (ex_catch_exception_unhandled, self);
11449}
11450
11451static void
11452re_set_catch_exception_unhandled (struct breakpoint *b)
11453{
11454 re_set_exception (ex_catch_exception_unhandled, b);
11455}
11456
11457static void
11458check_status_catch_exception_unhandled (bpstat bs)
11459{
11460 check_status_exception (ex_catch_exception_unhandled, bs);
11461}
11462
f7f9143b 11463static enum print_stop_action
348d480f 11464print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 11465{
348d480f 11466 return print_it_exception (ex_catch_exception_unhandled, bs);
f7f9143b
JB
11467}
11468
11469static void
a6d9a66e
UW
11470print_one_catch_exception_unhandled (struct breakpoint *b,
11471 struct bp_location **last_loc)
f7f9143b 11472{
a6d9a66e 11473 print_one_exception (ex_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
11474}
11475
11476static void
11477print_mention_catch_exception_unhandled (struct breakpoint *b)
11478{
11479 print_mention_exception (ex_catch_exception_unhandled, b);
11480}
11481
6149aea9
PA
11482static void
11483print_recreate_catch_exception_unhandled (struct breakpoint *b,
11484 struct ui_file *fp)
11485{
11486 print_recreate_exception (ex_catch_exception_unhandled, b, fp);
11487}
11488
2060206e 11489static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
11490
11491/* Virtual table for "catch assert" breakpoints. */
11492
28010a5d
PA
11493static void
11494dtor_catch_assert (struct breakpoint *b)
11495{
11496 dtor_exception (ex_catch_assert, b);
11497}
11498
11499static struct bp_location *
11500allocate_location_catch_assert (struct breakpoint *self)
11501{
11502 return allocate_location_exception (ex_catch_assert, self);
11503}
11504
11505static void
11506re_set_catch_assert (struct breakpoint *b)
11507{
11508 return re_set_exception (ex_catch_assert, b);
11509}
11510
11511static void
11512check_status_catch_assert (bpstat bs)
11513{
11514 check_status_exception (ex_catch_assert, bs);
11515}
11516
f7f9143b 11517static enum print_stop_action
348d480f 11518print_it_catch_assert (bpstat bs)
f7f9143b 11519{
348d480f 11520 return print_it_exception (ex_catch_assert, bs);
f7f9143b
JB
11521}
11522
11523static void
a6d9a66e 11524print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11525{
a6d9a66e 11526 print_one_exception (ex_catch_assert, b, last_loc);
f7f9143b
JB
11527}
11528
11529static void
11530print_mention_catch_assert (struct breakpoint *b)
11531{
11532 print_mention_exception (ex_catch_assert, b);
11533}
11534
6149aea9
PA
11535static void
11536print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
11537{
11538 print_recreate_exception (ex_catch_assert, b, fp);
11539}
11540
2060206e 11541static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 11542
f7f9143b
JB
11543/* Return a newly allocated copy of the first space-separated token
11544 in ARGSP, and then adjust ARGSP to point immediately after that
11545 token.
11546
11547 Return NULL if ARGPS does not contain any more tokens. */
11548
11549static char *
11550ada_get_next_arg (char **argsp)
11551{
11552 char *args = *argsp;
11553 char *end;
11554 char *result;
11555
0fcd72ba 11556 args = skip_spaces (args);
f7f9143b
JB
11557 if (args[0] == '\0')
11558 return NULL; /* No more arguments. */
11559
11560 /* Find the end of the current argument. */
11561
0fcd72ba 11562 end = skip_to_space (args);
f7f9143b
JB
11563
11564 /* Adjust ARGSP to point to the start of the next argument. */
11565
11566 *argsp = end;
11567
11568 /* Make a copy of the current argument and return it. */
11569
11570 result = xmalloc (end - args + 1);
11571 strncpy (result, args, end - args);
11572 result[end - args] = '\0';
11573
11574 return result;
11575}
11576
11577/* Split the arguments specified in a "catch exception" command.
11578 Set EX to the appropriate catchpoint type.
28010a5d 11579 Set EXCEP_STRING to the name of the specific exception if
5845583d
JB
11580 specified by the user.
11581 If a condition is found at the end of the arguments, the condition
11582 expression is stored in COND_STRING (memory must be deallocated
11583 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
11584
11585static void
11586catch_ada_exception_command_split (char *args,
11587 enum exception_catchpoint_kind *ex,
5845583d
JB
11588 char **excep_string,
11589 char **cond_string)
f7f9143b
JB
11590{
11591 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
11592 char *exception_name;
5845583d 11593 char *cond = NULL;
f7f9143b
JB
11594
11595 exception_name = ada_get_next_arg (&args);
5845583d
JB
11596 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
11597 {
11598 /* This is not an exception name; this is the start of a condition
11599 expression for a catchpoint on all exceptions. So, "un-get"
11600 this token, and set exception_name to NULL. */
11601 xfree (exception_name);
11602 exception_name = NULL;
11603 args -= 2;
11604 }
f7f9143b
JB
11605 make_cleanup (xfree, exception_name);
11606
5845583d 11607 /* Check to see if we have a condition. */
f7f9143b 11608
0fcd72ba 11609 args = skip_spaces (args);
5845583d
JB
11610 if (strncmp (args, "if", 2) == 0
11611 && (isspace (args[2]) || args[2] == '\0'))
11612 {
11613 args += 2;
11614 args = skip_spaces (args);
11615
11616 if (args[0] == '\0')
11617 error (_("Condition missing after `if' keyword"));
11618 cond = xstrdup (args);
11619 make_cleanup (xfree, cond);
11620
11621 args += strlen (args);
11622 }
11623
11624 /* Check that we do not have any more arguments. Anything else
11625 is unexpected. */
f7f9143b
JB
11626
11627 if (args[0] != '\0')
11628 error (_("Junk at end of expression"));
11629
11630 discard_cleanups (old_chain);
11631
11632 if (exception_name == NULL)
11633 {
11634 /* Catch all exceptions. */
11635 *ex = ex_catch_exception;
28010a5d 11636 *excep_string = NULL;
f7f9143b
JB
11637 }
11638 else if (strcmp (exception_name, "unhandled") == 0)
11639 {
11640 /* Catch unhandled exceptions. */
11641 *ex = ex_catch_exception_unhandled;
28010a5d 11642 *excep_string = NULL;
f7f9143b
JB
11643 }
11644 else
11645 {
11646 /* Catch a specific exception. */
11647 *ex = ex_catch_exception;
28010a5d 11648 *excep_string = exception_name;
f7f9143b 11649 }
5845583d 11650 *cond_string = cond;
f7f9143b
JB
11651}
11652
11653/* Return the name of the symbol on which we should break in order to
11654 implement a catchpoint of the EX kind. */
11655
11656static const char *
11657ada_exception_sym_name (enum exception_catchpoint_kind ex)
11658{
3eecfa55
JB
11659 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11660
11661 gdb_assert (data->exception_info != NULL);
0259addd 11662
f7f9143b
JB
11663 switch (ex)
11664 {
11665 case ex_catch_exception:
3eecfa55 11666 return (data->exception_info->catch_exception_sym);
f7f9143b
JB
11667 break;
11668 case ex_catch_exception_unhandled:
3eecfa55 11669 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b
JB
11670 break;
11671 case ex_catch_assert:
3eecfa55 11672 return (data->exception_info->catch_assert_sym);
f7f9143b
JB
11673 break;
11674 default:
11675 internal_error (__FILE__, __LINE__,
11676 _("unexpected catchpoint kind (%d)"), ex);
11677 }
11678}
11679
11680/* Return the breakpoint ops "virtual table" used for catchpoints
11681 of the EX kind. */
11682
c0a91b2b 11683static const struct breakpoint_ops *
4b9eee8c 11684ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex)
f7f9143b
JB
11685{
11686 switch (ex)
11687 {
11688 case ex_catch_exception:
11689 return (&catch_exception_breakpoint_ops);
11690 break;
11691 case ex_catch_exception_unhandled:
11692 return (&catch_exception_unhandled_breakpoint_ops);
11693 break;
11694 case ex_catch_assert:
11695 return (&catch_assert_breakpoint_ops);
11696 break;
11697 default:
11698 internal_error (__FILE__, __LINE__,
11699 _("unexpected catchpoint kind (%d)"), ex);
11700 }
11701}
11702
11703/* Return the condition that will be used to match the current exception
11704 being raised with the exception that the user wants to catch. This
11705 assumes that this condition is used when the inferior just triggered
11706 an exception catchpoint.
11707
11708 The string returned is a newly allocated string that needs to be
11709 deallocated later. */
11710
11711static char *
28010a5d 11712ada_exception_catchpoint_cond_string (const char *excep_string)
f7f9143b 11713{
3d0b0fa3
JB
11714 int i;
11715
0963b4bd 11716 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 11717 runtime units that have been compiled without debugging info; if
28010a5d 11718 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
11719 exception (e.g. "constraint_error") then, during the evaluation
11720 of the condition expression, the symbol lookup on this name would
0963b4bd 11721 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
11722 may then be set only on user-defined exceptions which have the
11723 same not-fully-qualified name (e.g. my_package.constraint_error).
11724
11725 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 11726 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
11727 exception constraint_error" is rewritten into "catch exception
11728 standard.constraint_error".
11729
11730 If an exception named contraint_error is defined in another package of
11731 the inferior program, then the only way to specify this exception as a
11732 breakpoint condition is to use its fully-qualified named:
11733 e.g. my_package.constraint_error. */
11734
11735 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
11736 {
28010a5d 11737 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3
JB
11738 {
11739 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
28010a5d 11740 excep_string);
3d0b0fa3
JB
11741 }
11742 }
28010a5d 11743 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
f7f9143b
JB
11744}
11745
11746/* Return the symtab_and_line that should be used to insert an exception
11747 catchpoint of the TYPE kind.
11748
28010a5d
PA
11749 EXCEP_STRING should contain the name of a specific exception that
11750 the catchpoint should catch, or NULL otherwise.
f7f9143b 11751
28010a5d
PA
11752 ADDR_STRING returns the name of the function where the real
11753 breakpoint that implements the catchpoints is set, depending on the
11754 type of catchpoint we need to create. */
f7f9143b
JB
11755
11756static struct symtab_and_line
28010a5d 11757ada_exception_sal (enum exception_catchpoint_kind ex, char *excep_string,
c0a91b2b 11758 char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
11759{
11760 const char *sym_name;
11761 struct symbol *sym;
f7f9143b 11762
0259addd
JB
11763 /* First, find out which exception support info to use. */
11764 ada_exception_support_info_sniffer ();
11765
11766 /* Then lookup the function on which we will break in order to catch
f7f9143b 11767 the Ada exceptions requested by the user. */
f7f9143b
JB
11768 sym_name = ada_exception_sym_name (ex);
11769 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
11770
f17011e0
JB
11771 /* We can assume that SYM is not NULL at this stage. If the symbol
11772 did not exist, ada_exception_support_info_sniffer would have
11773 raised an exception.
f7f9143b 11774
f17011e0
JB
11775 Also, ada_exception_support_info_sniffer should have already
11776 verified that SYM is a function symbol. */
11777 gdb_assert (sym != NULL);
11778 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
11779
11780 /* Set ADDR_STRING. */
f7f9143b
JB
11781 *addr_string = xstrdup (sym_name);
11782
f7f9143b 11783 /* Set OPS. */
4b9eee8c 11784 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 11785
f17011e0 11786 return find_function_start_sal (sym, 1);
f7f9143b
JB
11787}
11788
11789/* Parse the arguments (ARGS) of the "catch exception" command.
11790
f7f9143b
JB
11791 If the user asked the catchpoint to catch only a specific
11792 exception, then save the exception name in ADDR_STRING.
11793
5845583d
JB
11794 If the user provided a condition, then set COND_STRING to
11795 that condition expression (the memory must be deallocated
11796 after use). Otherwise, set COND_STRING to NULL.
11797
f7f9143b
JB
11798 See ada_exception_sal for a description of all the remaining
11799 function arguments of this function. */
11800
9ac4176b 11801static struct symtab_and_line
f7f9143b 11802ada_decode_exception_location (char *args, char **addr_string,
28010a5d 11803 char **excep_string,
5845583d 11804 char **cond_string,
c0a91b2b 11805 const struct breakpoint_ops **ops)
f7f9143b
JB
11806{
11807 enum exception_catchpoint_kind ex;
11808
5845583d 11809 catch_ada_exception_command_split (args, &ex, excep_string, cond_string);
28010a5d
PA
11810 return ada_exception_sal (ex, *excep_string, addr_string, ops);
11811}
11812
11813/* Create an Ada exception catchpoint. */
11814
11815static void
11816create_ada_exception_catchpoint (struct gdbarch *gdbarch,
11817 struct symtab_and_line sal,
11818 char *addr_string,
11819 char *excep_string,
5845583d 11820 char *cond_string,
c0a91b2b 11821 const struct breakpoint_ops *ops,
28010a5d
PA
11822 int tempflag,
11823 int from_tty)
11824{
11825 struct ada_catchpoint *c;
11826
11827 c = XNEW (struct ada_catchpoint);
11828 init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string,
11829 ops, tempflag, from_tty);
11830 c->excep_string = excep_string;
11831 create_excep_cond_exprs (c);
5845583d
JB
11832 if (cond_string != NULL)
11833 set_breakpoint_condition (&c->base, cond_string, from_tty);
3ea46bff 11834 install_breakpoint (0, &c->base, 1);
f7f9143b
JB
11835}
11836
9ac4176b
PA
11837/* Implement the "catch exception" command. */
11838
11839static void
11840catch_ada_exception_command (char *arg, int from_tty,
11841 struct cmd_list_element *command)
11842{
11843 struct gdbarch *gdbarch = get_current_arch ();
11844 int tempflag;
11845 struct symtab_and_line sal;
11846 char *addr_string = NULL;
28010a5d 11847 char *excep_string = NULL;
5845583d 11848 char *cond_string = NULL;
c0a91b2b 11849 const struct breakpoint_ops *ops = NULL;
9ac4176b
PA
11850
11851 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
11852
11853 if (!arg)
11854 arg = "";
5845583d
JB
11855 sal = ada_decode_exception_location (arg, &addr_string, &excep_string,
11856 &cond_string, &ops);
28010a5d 11857 create_ada_exception_catchpoint (gdbarch, sal, addr_string,
5845583d
JB
11858 excep_string, cond_string, ops,
11859 tempflag, from_tty);
9ac4176b
PA
11860}
11861
5845583d
JB
11862/* Assuming that ARGS contains the arguments of a "catch assert"
11863 command, parse those arguments and return a symtab_and_line object
11864 for a failed assertion catchpoint.
11865
11866 Set ADDR_STRING to the name of the function where the real
11867 breakpoint that implements the catchpoint is set.
11868
11869 If ARGS contains a condition, set COND_STRING to that condition
11870 (the memory needs to be deallocated after use). Otherwise, set
11871 COND_STRING to NULL. */
11872
9ac4176b 11873static struct symtab_and_line
f7f9143b 11874ada_decode_assert_location (char *args, char **addr_string,
5845583d 11875 char **cond_string,
c0a91b2b 11876 const struct breakpoint_ops **ops)
f7f9143b 11877{
5845583d 11878 args = skip_spaces (args);
f7f9143b 11879
5845583d
JB
11880 /* Check whether a condition was provided. */
11881 if (strncmp (args, "if", 2) == 0
11882 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 11883 {
5845583d 11884 args += 2;
0fcd72ba 11885 args = skip_spaces (args);
5845583d
JB
11886 if (args[0] == '\0')
11887 error (_("condition missing after `if' keyword"));
11888 *cond_string = xstrdup (args);
f7f9143b
JB
11889 }
11890
5845583d
JB
11891 /* Otherwise, there should be no other argument at the end of
11892 the command. */
11893 else if (args[0] != '\0')
11894 error (_("Junk at end of arguments."));
11895
28010a5d 11896 return ada_exception_sal (ex_catch_assert, NULL, addr_string, ops);
f7f9143b
JB
11897}
11898
9ac4176b
PA
11899/* Implement the "catch assert" command. */
11900
11901static void
11902catch_assert_command (char *arg, int from_tty,
11903 struct cmd_list_element *command)
11904{
11905 struct gdbarch *gdbarch = get_current_arch ();
11906 int tempflag;
11907 struct symtab_and_line sal;
11908 char *addr_string = NULL;
5845583d 11909 char *cond_string = NULL;
c0a91b2b 11910 const struct breakpoint_ops *ops = NULL;
9ac4176b
PA
11911
11912 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
11913
11914 if (!arg)
11915 arg = "";
5845583d 11916 sal = ada_decode_assert_location (arg, &addr_string, &cond_string, &ops);
28010a5d 11917 create_ada_exception_catchpoint (gdbarch, sal, addr_string,
5845583d
JB
11918 NULL, cond_string, ops, tempflag,
11919 from_tty);
9ac4176b 11920}
4c4b4cd2
PH
11921 /* Operators */
11922/* Information about operators given special treatment in functions
11923 below. */
11924/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
11925
11926#define ADA_OPERATORS \
11927 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
11928 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
11929 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
11930 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
11931 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
11932 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
11933 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
11934 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
11935 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
11936 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
11937 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
11938 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
11939 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
11940 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
11941 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
11942 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
11943 OP_DEFN (OP_OTHERS, 1, 1, 0) \
11944 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
11945 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
11946
11947static void
554794dc
SDJ
11948ada_operator_length (const struct expression *exp, int pc, int *oplenp,
11949 int *argsp)
4c4b4cd2
PH
11950{
11951 switch (exp->elts[pc - 1].opcode)
11952 {
76a01679 11953 default:
4c4b4cd2
PH
11954 operator_length_standard (exp, pc, oplenp, argsp);
11955 break;
11956
11957#define OP_DEFN(op, len, args, binop) \
11958 case op: *oplenp = len; *argsp = args; break;
11959 ADA_OPERATORS;
11960#undef OP_DEFN
52ce6436
PH
11961
11962 case OP_AGGREGATE:
11963 *oplenp = 3;
11964 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
11965 break;
11966
11967 case OP_CHOICES:
11968 *oplenp = 3;
11969 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
11970 break;
4c4b4cd2
PH
11971 }
11972}
11973
c0201579
JK
11974/* Implementation of the exp_descriptor method operator_check. */
11975
11976static int
11977ada_operator_check (struct expression *exp, int pos,
11978 int (*objfile_func) (struct objfile *objfile, void *data),
11979 void *data)
11980{
11981 const union exp_element *const elts = exp->elts;
11982 struct type *type = NULL;
11983
11984 switch (elts[pos].opcode)
11985 {
11986 case UNOP_IN_RANGE:
11987 case UNOP_QUAL:
11988 type = elts[pos + 1].type;
11989 break;
11990
11991 default:
11992 return operator_check_standard (exp, pos, objfile_func, data);
11993 }
11994
11995 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
11996
11997 if (type && TYPE_OBJFILE (type)
11998 && (*objfile_func) (TYPE_OBJFILE (type), data))
11999 return 1;
12000
12001 return 0;
12002}
12003
4c4b4cd2
PH
12004static char *
12005ada_op_name (enum exp_opcode opcode)
12006{
12007 switch (opcode)
12008 {
76a01679 12009 default:
4c4b4cd2 12010 return op_name_standard (opcode);
52ce6436 12011
4c4b4cd2
PH
12012#define OP_DEFN(op, len, args, binop) case op: return #op;
12013 ADA_OPERATORS;
12014#undef OP_DEFN
52ce6436
PH
12015
12016 case OP_AGGREGATE:
12017 return "OP_AGGREGATE";
12018 case OP_CHOICES:
12019 return "OP_CHOICES";
12020 case OP_NAME:
12021 return "OP_NAME";
4c4b4cd2
PH
12022 }
12023}
12024
12025/* As for operator_length, but assumes PC is pointing at the first
12026 element of the operator, and gives meaningful results only for the
52ce6436 12027 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
12028
12029static void
76a01679
JB
12030ada_forward_operator_length (struct expression *exp, int pc,
12031 int *oplenp, int *argsp)
4c4b4cd2 12032{
76a01679 12033 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
12034 {
12035 default:
12036 *oplenp = *argsp = 0;
12037 break;
52ce6436 12038
4c4b4cd2
PH
12039#define OP_DEFN(op, len, args, binop) \
12040 case op: *oplenp = len; *argsp = args; break;
12041 ADA_OPERATORS;
12042#undef OP_DEFN
52ce6436
PH
12043
12044 case OP_AGGREGATE:
12045 *oplenp = 3;
12046 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
12047 break;
12048
12049 case OP_CHOICES:
12050 *oplenp = 3;
12051 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
12052 break;
12053
12054 case OP_STRING:
12055 case OP_NAME:
12056 {
12057 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 12058
52ce6436
PH
12059 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
12060 *argsp = 0;
12061 break;
12062 }
4c4b4cd2
PH
12063 }
12064}
12065
12066static int
12067ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
12068{
12069 enum exp_opcode op = exp->elts[elt].opcode;
12070 int oplen, nargs;
12071 int pc = elt;
12072 int i;
76a01679 12073
4c4b4cd2
PH
12074 ada_forward_operator_length (exp, elt, &oplen, &nargs);
12075
76a01679 12076 switch (op)
4c4b4cd2 12077 {
76a01679 12078 /* Ada attributes ('Foo). */
4c4b4cd2
PH
12079 case OP_ATR_FIRST:
12080 case OP_ATR_LAST:
12081 case OP_ATR_LENGTH:
12082 case OP_ATR_IMAGE:
12083 case OP_ATR_MAX:
12084 case OP_ATR_MIN:
12085 case OP_ATR_MODULUS:
12086 case OP_ATR_POS:
12087 case OP_ATR_SIZE:
12088 case OP_ATR_TAG:
12089 case OP_ATR_VAL:
12090 break;
12091
12092 case UNOP_IN_RANGE:
12093 case UNOP_QUAL:
323e0a4a
AC
12094 /* XXX: gdb_sprint_host_address, type_sprint */
12095 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
12096 gdb_print_host_address (exp->elts[pc + 1].type, stream);
12097 fprintf_filtered (stream, " (");
12098 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
12099 fprintf_filtered (stream, ")");
12100 break;
12101 case BINOP_IN_BOUNDS:
52ce6436
PH
12102 fprintf_filtered (stream, " (%d)",
12103 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
12104 break;
12105 case TERNOP_IN_RANGE:
12106 break;
12107
52ce6436
PH
12108 case OP_AGGREGATE:
12109 case OP_OTHERS:
12110 case OP_DISCRETE_RANGE:
12111 case OP_POSITIONAL:
12112 case OP_CHOICES:
12113 break;
12114
12115 case OP_NAME:
12116 case OP_STRING:
12117 {
12118 char *name = &exp->elts[elt + 2].string;
12119 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 12120
52ce6436
PH
12121 fprintf_filtered (stream, "Text: `%.*s'", len, name);
12122 break;
12123 }
12124
4c4b4cd2
PH
12125 default:
12126 return dump_subexp_body_standard (exp, stream, elt);
12127 }
12128
12129 elt += oplen;
12130 for (i = 0; i < nargs; i += 1)
12131 elt = dump_subexp (exp, stream, elt);
12132
12133 return elt;
12134}
12135
12136/* The Ada extension of print_subexp (q.v.). */
12137
76a01679
JB
12138static void
12139ada_print_subexp (struct expression *exp, int *pos,
12140 struct ui_file *stream, enum precedence prec)
4c4b4cd2 12141{
52ce6436 12142 int oplen, nargs, i;
4c4b4cd2
PH
12143 int pc = *pos;
12144 enum exp_opcode op = exp->elts[pc].opcode;
12145
12146 ada_forward_operator_length (exp, pc, &oplen, &nargs);
12147
52ce6436 12148 *pos += oplen;
4c4b4cd2
PH
12149 switch (op)
12150 {
12151 default:
52ce6436 12152 *pos -= oplen;
4c4b4cd2
PH
12153 print_subexp_standard (exp, pos, stream, prec);
12154 return;
12155
12156 case OP_VAR_VALUE:
4c4b4cd2
PH
12157 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
12158 return;
12159
12160 case BINOP_IN_BOUNDS:
323e0a4a 12161 /* XXX: sprint_subexp */
4c4b4cd2 12162 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12163 fputs_filtered (" in ", stream);
4c4b4cd2 12164 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12165 fputs_filtered ("'range", stream);
4c4b4cd2 12166 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
12167 fprintf_filtered (stream, "(%ld)",
12168 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
12169 return;
12170
12171 case TERNOP_IN_RANGE:
4c4b4cd2 12172 if (prec >= PREC_EQUAL)
76a01679 12173 fputs_filtered ("(", stream);
323e0a4a 12174 /* XXX: sprint_subexp */
4c4b4cd2 12175 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12176 fputs_filtered (" in ", stream);
4c4b4cd2
PH
12177 print_subexp (exp, pos, stream, PREC_EQUAL);
12178 fputs_filtered (" .. ", stream);
12179 print_subexp (exp, pos, stream, PREC_EQUAL);
12180 if (prec >= PREC_EQUAL)
76a01679
JB
12181 fputs_filtered (")", stream);
12182 return;
4c4b4cd2
PH
12183
12184 case OP_ATR_FIRST:
12185 case OP_ATR_LAST:
12186 case OP_ATR_LENGTH:
12187 case OP_ATR_IMAGE:
12188 case OP_ATR_MAX:
12189 case OP_ATR_MIN:
12190 case OP_ATR_MODULUS:
12191 case OP_ATR_POS:
12192 case OP_ATR_SIZE:
12193 case OP_ATR_TAG:
12194 case OP_ATR_VAL:
4c4b4cd2 12195 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
12196 {
12197 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
12198 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0);
12199 *pos += 3;
12200 }
4c4b4cd2 12201 else
76a01679 12202 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
12203 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
12204 if (nargs > 1)
76a01679
JB
12205 {
12206 int tem;
5b4ee69b 12207
76a01679
JB
12208 for (tem = 1; tem < nargs; tem += 1)
12209 {
12210 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
12211 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
12212 }
12213 fputs_filtered (")", stream);
12214 }
4c4b4cd2 12215 return;
14f9c5c9 12216
4c4b4cd2 12217 case UNOP_QUAL:
4c4b4cd2
PH
12218 type_print (exp->elts[pc + 1].type, "", stream, 0);
12219 fputs_filtered ("'(", stream);
12220 print_subexp (exp, pos, stream, PREC_PREFIX);
12221 fputs_filtered (")", stream);
12222 return;
14f9c5c9 12223
4c4b4cd2 12224 case UNOP_IN_RANGE:
323e0a4a 12225 /* XXX: sprint_subexp */
4c4b4cd2 12226 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 12227 fputs_filtered (" in ", stream);
4c4b4cd2
PH
12228 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0);
12229 return;
52ce6436
PH
12230
12231 case OP_DISCRETE_RANGE:
12232 print_subexp (exp, pos, stream, PREC_SUFFIX);
12233 fputs_filtered ("..", stream);
12234 print_subexp (exp, pos, stream, PREC_SUFFIX);
12235 return;
12236
12237 case OP_OTHERS:
12238 fputs_filtered ("others => ", stream);
12239 print_subexp (exp, pos, stream, PREC_SUFFIX);
12240 return;
12241
12242 case OP_CHOICES:
12243 for (i = 0; i < nargs-1; i += 1)
12244 {
12245 if (i > 0)
12246 fputs_filtered ("|", stream);
12247 print_subexp (exp, pos, stream, PREC_SUFFIX);
12248 }
12249 fputs_filtered (" => ", stream);
12250 print_subexp (exp, pos, stream, PREC_SUFFIX);
12251 return;
12252
12253 case OP_POSITIONAL:
12254 print_subexp (exp, pos, stream, PREC_SUFFIX);
12255 return;
12256
12257 case OP_AGGREGATE:
12258 fputs_filtered ("(", stream);
12259 for (i = 0; i < nargs; i += 1)
12260 {
12261 if (i > 0)
12262 fputs_filtered (", ", stream);
12263 print_subexp (exp, pos, stream, PREC_SUFFIX);
12264 }
12265 fputs_filtered (")", stream);
12266 return;
4c4b4cd2
PH
12267 }
12268}
14f9c5c9
AS
12269
12270/* Table mapping opcodes into strings for printing operators
12271 and precedences of the operators. */
12272
d2e4a39e
AS
12273static const struct op_print ada_op_print_tab[] = {
12274 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
12275 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
12276 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
12277 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
12278 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
12279 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
12280 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
12281 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
12282 {"<=", BINOP_LEQ, PREC_ORDER, 0},
12283 {">=", BINOP_GEQ, PREC_ORDER, 0},
12284 {">", BINOP_GTR, PREC_ORDER, 0},
12285 {"<", BINOP_LESS, PREC_ORDER, 0},
12286 {">>", BINOP_RSH, PREC_SHIFT, 0},
12287 {"<<", BINOP_LSH, PREC_SHIFT, 0},
12288 {"+", BINOP_ADD, PREC_ADD, 0},
12289 {"-", BINOP_SUB, PREC_ADD, 0},
12290 {"&", BINOP_CONCAT, PREC_ADD, 0},
12291 {"*", BINOP_MUL, PREC_MUL, 0},
12292 {"/", BINOP_DIV, PREC_MUL, 0},
12293 {"rem", BINOP_REM, PREC_MUL, 0},
12294 {"mod", BINOP_MOD, PREC_MUL, 0},
12295 {"**", BINOP_EXP, PREC_REPEAT, 0},
12296 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
12297 {"-", UNOP_NEG, PREC_PREFIX, 0},
12298 {"+", UNOP_PLUS, PREC_PREFIX, 0},
12299 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
12300 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
12301 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
12302 {".all", UNOP_IND, PREC_SUFFIX, 1},
12303 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
12304 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
d2e4a39e 12305 {NULL, 0, 0, 0}
14f9c5c9
AS
12306};
12307\f
72d5681a
PH
12308enum ada_primitive_types {
12309 ada_primitive_type_int,
12310 ada_primitive_type_long,
12311 ada_primitive_type_short,
12312 ada_primitive_type_char,
12313 ada_primitive_type_float,
12314 ada_primitive_type_double,
12315 ada_primitive_type_void,
12316 ada_primitive_type_long_long,
12317 ada_primitive_type_long_double,
12318 ada_primitive_type_natural,
12319 ada_primitive_type_positive,
12320 ada_primitive_type_system_address,
12321 nr_ada_primitive_types
12322};
6c038f32
PH
12323
12324static void
d4a9a881 12325ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
12326 struct language_arch_info *lai)
12327{
d4a9a881 12328 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 12329
72d5681a 12330 lai->primitive_type_vector
d4a9a881 12331 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 12332 struct type *);
e9bb382b
UW
12333
12334 lai->primitive_type_vector [ada_primitive_type_int]
12335 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12336 0, "integer");
12337 lai->primitive_type_vector [ada_primitive_type_long]
12338 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
12339 0, "long_integer");
12340 lai->primitive_type_vector [ada_primitive_type_short]
12341 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
12342 0, "short_integer");
12343 lai->string_char_type
12344 = lai->primitive_type_vector [ada_primitive_type_char]
12345 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
12346 lai->primitive_type_vector [ada_primitive_type_float]
12347 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
12348 "float", NULL);
12349 lai->primitive_type_vector [ada_primitive_type_double]
12350 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
12351 "long_float", NULL);
12352 lai->primitive_type_vector [ada_primitive_type_long_long]
12353 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
12354 0, "long_long_integer");
12355 lai->primitive_type_vector [ada_primitive_type_long_double]
12356 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
12357 "long_long_float", NULL);
12358 lai->primitive_type_vector [ada_primitive_type_natural]
12359 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12360 0, "natural");
12361 lai->primitive_type_vector [ada_primitive_type_positive]
12362 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12363 0, "positive");
12364 lai->primitive_type_vector [ada_primitive_type_void]
12365 = builtin->builtin_void;
12366
12367 lai->primitive_type_vector [ada_primitive_type_system_address]
12368 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
72d5681a
PH
12369 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
12370 = "system__address";
fbb06eb1 12371
47e729a8 12372 lai->bool_type_symbol = NULL;
fbb06eb1 12373 lai->bool_type_default = builtin->builtin_bool;
6c038f32 12374}
6c038f32
PH
12375\f
12376 /* Language vector */
12377
12378/* Not really used, but needed in the ada_language_defn. */
12379
12380static void
6c7a06a3 12381emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 12382{
6c7a06a3 12383 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
12384}
12385
12386static int
12387parse (void)
12388{
12389 warnings_issued = 0;
12390 return ada_parse ();
12391}
12392
12393static const struct exp_descriptor ada_exp_descriptor = {
12394 ada_print_subexp,
12395 ada_operator_length,
c0201579 12396 ada_operator_check,
6c038f32
PH
12397 ada_op_name,
12398 ada_dump_subexp_body,
12399 ada_evaluate_subexp
12400};
12401
1a119f36 12402/* Implement the "la_get_symbol_name_cmp" language_defn method
74ccd7f5
JB
12403 for Ada. */
12404
1a119f36
JB
12405static symbol_name_cmp_ftype
12406ada_get_symbol_name_cmp (const char *lookup_name)
74ccd7f5
JB
12407{
12408 if (should_use_wild_match (lookup_name))
12409 return wild_match;
12410 else
12411 return compare_names;
12412}
12413
6c038f32
PH
12414const struct language_defn ada_language_defn = {
12415 "ada", /* Language name */
12416 language_ada,
6c038f32
PH
12417 range_check_off,
12418 type_check_off,
12419 case_sensitive_on, /* Yes, Ada is case-insensitive, but
12420 that's not quite what this means. */
6c038f32 12421 array_row_major,
9a044a89 12422 macro_expansion_no,
6c038f32
PH
12423 &ada_exp_descriptor,
12424 parse,
12425 ada_error,
12426 resolve,
12427 ada_printchar, /* Print a character constant */
12428 ada_printstr, /* Function to print string constant */
12429 emit_char, /* Function to print single char (not used) */
6c038f32 12430 ada_print_type, /* Print a type using appropriate syntax */
be942545 12431 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
12432 ada_val_print, /* Print a value using appropriate syntax */
12433 ada_value_print, /* Print a top-level value */
12434 NULL, /* Language specific skip_trampoline */
2b2d9e11 12435 NULL, /* name_of_this */
6c038f32
PH
12436 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
12437 basic_lookup_transparent_type, /* lookup_transparent_type */
12438 ada_la_decode, /* Language specific symbol demangler */
0963b4bd
MS
12439 NULL, /* Language specific
12440 class_name_from_physname */
6c038f32
PH
12441 ada_op_print_tab, /* expression operators for printing */
12442 0, /* c-style arrays */
12443 1, /* String lower bound */
6c038f32 12444 ada_get_gdb_completer_word_break_characters,
41d27058 12445 ada_make_symbol_completion_list,
72d5681a 12446 ada_language_arch_info,
e79af960 12447 ada_print_array_index,
41f1b697 12448 default_pass_by_reference,
ae6a3a4c 12449 c_get_string,
1a119f36 12450 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
f8eba3c6 12451 ada_iterate_over_symbols,
6c038f32
PH
12452 LANG_MAGIC
12453};
12454
2c0b251b
PA
12455/* Provide a prototype to silence -Wmissing-prototypes. */
12456extern initialize_file_ftype _initialize_ada_language;
12457
5bf03f13
JB
12458/* Command-list for the "set/show ada" prefix command. */
12459static struct cmd_list_element *set_ada_list;
12460static struct cmd_list_element *show_ada_list;
12461
12462/* Implement the "set ada" prefix command. */
12463
12464static void
12465set_ada_command (char *arg, int from_tty)
12466{
12467 printf_unfiltered (_(\
12468"\"set ada\" must be followed by the name of a setting.\n"));
12469 help_list (set_ada_list, "set ada ", -1, gdb_stdout);
12470}
12471
12472/* Implement the "show ada" prefix command. */
12473
12474static void
12475show_ada_command (char *args, int from_tty)
12476{
12477 cmd_show_list (show_ada_list, from_tty, "");
12478}
12479
2060206e
PA
12480static void
12481initialize_ada_catchpoint_ops (void)
12482{
12483 struct breakpoint_ops *ops;
12484
12485 initialize_breakpoint_ops ();
12486
12487 ops = &catch_exception_breakpoint_ops;
12488 *ops = bkpt_breakpoint_ops;
12489 ops->dtor = dtor_catch_exception;
12490 ops->allocate_location = allocate_location_catch_exception;
12491 ops->re_set = re_set_catch_exception;
12492 ops->check_status = check_status_catch_exception;
12493 ops->print_it = print_it_catch_exception;
12494 ops->print_one = print_one_catch_exception;
12495 ops->print_mention = print_mention_catch_exception;
12496 ops->print_recreate = print_recreate_catch_exception;
12497
12498 ops = &catch_exception_unhandled_breakpoint_ops;
12499 *ops = bkpt_breakpoint_ops;
12500 ops->dtor = dtor_catch_exception_unhandled;
12501 ops->allocate_location = allocate_location_catch_exception_unhandled;
12502 ops->re_set = re_set_catch_exception_unhandled;
12503 ops->check_status = check_status_catch_exception_unhandled;
12504 ops->print_it = print_it_catch_exception_unhandled;
12505 ops->print_one = print_one_catch_exception_unhandled;
12506 ops->print_mention = print_mention_catch_exception_unhandled;
12507 ops->print_recreate = print_recreate_catch_exception_unhandled;
12508
12509 ops = &catch_assert_breakpoint_ops;
12510 *ops = bkpt_breakpoint_ops;
12511 ops->dtor = dtor_catch_assert;
12512 ops->allocate_location = allocate_location_catch_assert;
12513 ops->re_set = re_set_catch_assert;
12514 ops->check_status = check_status_catch_assert;
12515 ops->print_it = print_it_catch_assert;
12516 ops->print_one = print_one_catch_assert;
12517 ops->print_mention = print_mention_catch_assert;
12518 ops->print_recreate = print_recreate_catch_assert;
12519}
12520
d2e4a39e 12521void
6c038f32 12522_initialize_ada_language (void)
14f9c5c9 12523{
6c038f32
PH
12524 add_language (&ada_language_defn);
12525
2060206e
PA
12526 initialize_ada_catchpoint_ops ();
12527
5bf03f13
JB
12528 add_prefix_cmd ("ada", no_class, set_ada_command,
12529 _("Prefix command for changing Ada-specfic settings"),
12530 &set_ada_list, "set ada ", 0, &setlist);
12531
12532 add_prefix_cmd ("ada", no_class, show_ada_command,
12533 _("Generic command for showing Ada-specific settings."),
12534 &show_ada_list, "show ada ", 0, &showlist);
12535
12536 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
12537 &trust_pad_over_xvs, _("\
12538Enable or disable an optimization trusting PAD types over XVS types"), _("\
12539Show whether an optimization trusting PAD types over XVS types is activated"),
12540 _("\
12541This is related to the encoding used by the GNAT compiler. The debugger\n\
12542should normally trust the contents of PAD types, but certain older versions\n\
12543of GNAT have a bug that sometimes causes the information in the PAD type\n\
12544to be incorrect. Turning this setting \"off\" allows the debugger to\n\
12545work around this bug. It is always safe to turn this option \"off\", but\n\
12546this incurs a slight performance penalty, so it is recommended to NOT change\n\
12547this option to \"off\" unless necessary."),
12548 NULL, NULL, &set_ada_list, &show_ada_list);
12549
9ac4176b
PA
12550 add_catch_command ("exception", _("\
12551Catch Ada exceptions, when raised.\n\
12552With an argument, catch only exceptions with the given name."),
12553 catch_ada_exception_command,
12554 NULL,
12555 CATCH_PERMANENT,
12556 CATCH_TEMPORARY);
12557 add_catch_command ("assert", _("\
12558Catch failed Ada assertions, when raised.\n\
12559With an argument, catch only exceptions with the given name."),
12560 catch_assert_command,
12561 NULL,
12562 CATCH_PERMANENT,
12563 CATCH_TEMPORARY);
12564
6c038f32 12565 varsize_limit = 65536;
6c038f32
PH
12566
12567 obstack_init (&symbol_list_obstack);
12568
12569 decoded_names_store = htab_create_alloc
12570 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
12571 NULL, xcalloc, xfree);
6b69afc4 12572
e802dbe0
JB
12573 /* Setup per-inferior data. */
12574 observer_attach_inferior_exit (ada_inferior_exit);
12575 ada_inferior_data
12576 = register_inferior_data_with_cleanup (ada_inferior_data_cleanup);
14f9c5c9 12577}