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