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