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