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