]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
* p-valprint.c (pascal_val_print): Use extract_typed_address
[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
d2e4a39e 82static struct type *desc_data_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 (struct type *, struct expression *,
4c4b4cd2 161 int *, enum noside);
14f9c5c9 162
d2e4a39e 163static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 164
d2e4a39e 165static int is_dynamic_field (struct type *, int);
14f9c5c9 166
10a2c479 167static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 168 const gdb_byte *,
4c4b4cd2
PH
169 CORE_ADDR, struct value *);
170
171static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 172
d2e4a39e 173static struct type *to_fixed_range_type (char *, struct value *,
4c4b4cd2 174 struct objfile *);
14f9c5c9 175
d2e4a39e 176static struct type *to_static_fixed_type (struct type *);
f192137b 177static struct type *static_unwrap_type (struct type *type);
14f9c5c9 178
d2e4a39e 179static struct value *unwrap_value (struct value *);
14f9c5c9 180
d2e4a39e 181static struct type *packed_array_type (struct type *, long *);
14f9c5c9 182
d2e4a39e 183static struct type *decode_packed_array_type (struct type *);
14f9c5c9 184
d2e4a39e 185static struct value *decode_packed_array (struct value *);
14f9c5c9 186
d2e4a39e 187static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 188 struct value **);
14f9c5c9 189
52ce6436
PH
190static void move_bits (gdb_byte *, int, const gdb_byte *, int, int);
191
4c4b4cd2
PH
192static struct value *coerce_unspec_val_to_type (struct value *,
193 struct type *);
14f9c5c9 194
d2e4a39e 195static struct value *get_var_value (char *, char *);
14f9c5c9 196
d2e4a39e 197static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 198
d2e4a39e 199static int equiv_types (struct type *, struct type *);
14f9c5c9 200
d2e4a39e 201static int is_name_suffix (const char *);
14f9c5c9 202
d2e4a39e 203static int wild_match (const char *, int, const char *);
14f9c5c9 204
d2e4a39e 205static struct value *ada_coerce_ref (struct value *);
14f9c5c9 206
4c4b4cd2
PH
207static LONGEST pos_atr (struct value *);
208
3cb382c9 209static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 210
d2e4a39e 211static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 212
4c4b4cd2
PH
213static struct symbol *standard_lookup (const char *, const struct block *,
214 domain_enum);
14f9c5c9 215
4c4b4cd2
PH
216static struct value *ada_search_struct_field (char *, struct value *, int,
217 struct type *);
218
219static struct value *ada_value_primitive_field (struct value *, int, int,
220 struct type *);
221
76a01679 222static int find_struct_field (char *, struct type *, int,
52ce6436 223 struct type **, int *, int *, int *, int *);
4c4b4cd2
PH
224
225static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
226 struct value *);
227
228static struct value *ada_to_fixed_value (struct value *);
14f9c5c9 229
4c4b4cd2
PH
230static int ada_resolve_function (struct ada_symbol_info *, int,
231 struct value **, int, const char *,
232 struct type *);
233
234static struct value *ada_coerce_to_simple_array (struct value *);
235
236static int ada_is_direct_array_type (struct type *);
237
72d5681a
PH
238static void ada_language_arch_info (struct gdbarch *,
239 struct language_arch_info *);
714e53ab
PH
240
241static void check_size (const struct type *);
52ce6436
PH
242
243static struct value *ada_index_struct_field (int, struct value *, int,
244 struct type *);
245
246static struct value *assign_aggregate (struct value *, struct value *,
247 struct expression *, int *, enum noside);
248
249static void aggregate_assign_from_choices (struct value *, struct value *,
250 struct expression *,
251 int *, LONGEST *, int *,
252 int, LONGEST, LONGEST);
253
254static void aggregate_assign_positional (struct value *, struct value *,
255 struct expression *,
256 int *, LONGEST *, int *, int,
257 LONGEST, LONGEST);
258
259
260static void aggregate_assign_others (struct value *, struct value *,
261 struct expression *,
262 int *, LONGEST *, int, LONGEST, LONGEST);
263
264
265static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
266
267
268static struct value *ada_evaluate_subexp (struct type *, struct expression *,
269 int *, enum noside);
270
271static void ada_forward_operator_length (struct expression *, int, int *,
272 int *);
4c4b4cd2
PH
273\f
274
76a01679 275
4c4b4cd2 276/* Maximum-sized dynamic type. */
14f9c5c9
AS
277static unsigned int varsize_limit;
278
4c4b4cd2
PH
279/* FIXME: brobecker/2003-09-17: No longer a const because it is
280 returned by a function that does not return a const char *. */
281static char *ada_completer_word_break_characters =
282#ifdef VMS
283 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
284#else
14f9c5c9 285 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 286#endif
14f9c5c9 287
4c4b4cd2 288/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 289static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 290 = "__gnat_ada_main_program_name";
14f9c5c9 291
4c4b4cd2
PH
292/* Limit on the number of warnings to raise per expression evaluation. */
293static int warning_limit = 2;
294
295/* Number of warning messages issued; reset to 0 by cleanups after
296 expression evaluation. */
297static int warnings_issued = 0;
298
299static const char *known_runtime_file_name_patterns[] = {
300 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
301};
302
303static const char *known_auxiliary_function_name_patterns[] = {
304 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
305};
306
307/* Space for allocating results of ada_lookup_symbol_list. */
308static struct obstack symbol_list_obstack;
309
310 /* Utilities */
311
41d27058
JB
312/* Given DECODED_NAME a string holding a symbol name in its
313 decoded form (ie using the Ada dotted notation), returns
314 its unqualified name. */
315
316static const char *
317ada_unqualified_name (const char *decoded_name)
318{
319 const char *result = strrchr (decoded_name, '.');
320
321 if (result != NULL)
322 result++; /* Skip the dot... */
323 else
324 result = decoded_name;
325
326 return result;
327}
328
329/* Return a string starting with '<', followed by STR, and '>'.
330 The result is good until the next call. */
331
332static char *
333add_angle_brackets (const char *str)
334{
335 static char *result = NULL;
336
337 xfree (result);
88c15c34 338 result = xstrprintf ("<%s>", str);
41d27058
JB
339 return result;
340}
96d887e8 341
4c4b4cd2
PH
342static char *
343ada_get_gdb_completer_word_break_characters (void)
344{
345 return ada_completer_word_break_characters;
346}
347
e79af960
JB
348/* Print an array element index using the Ada syntax. */
349
350static void
351ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 352 const struct value_print_options *options)
e79af960 353{
79a45b7d 354 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
355 fprintf_filtered (stream, " => ");
356}
357
4c4b4cd2
PH
358/* Read the string located at ADDR from the inferior and store the
359 result into BUF. */
360
361static void
14f9c5c9
AS
362extract_string (CORE_ADDR addr, char *buf)
363{
d2e4a39e 364 int char_index = 0;
14f9c5c9 365
4c4b4cd2
PH
366 /* Loop, reading one byte at a time, until we reach the '\000'
367 end-of-string marker. */
d2e4a39e
AS
368 do
369 {
370 target_read_memory (addr + char_index * sizeof (char),
4c4b4cd2 371 buf + char_index * sizeof (char), sizeof (char));
d2e4a39e
AS
372 char_index++;
373 }
374 while (buf[char_index - 1] != '\000');
14f9c5c9
AS
375}
376
f27cf670 377/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 378 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 379 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 380
f27cf670
AS
381void *
382grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 383{
d2e4a39e
AS
384 if (*size < min_size)
385 {
386 *size *= 2;
387 if (*size < min_size)
4c4b4cd2 388 *size = min_size;
f27cf670 389 vect = xrealloc (vect, *size * element_size);
d2e4a39e 390 }
f27cf670 391 return vect;
14f9c5c9
AS
392}
393
394/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 395 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
396
397static int
ebf56fd3 398field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
399{
400 int len = strlen (target);
d2e4a39e 401 return
4c4b4cd2
PH
402 (strncmp (field_name, target, len) == 0
403 && (field_name[len] == '\0'
404 || (strncmp (field_name + len, "___", 3) == 0
76a01679
JB
405 && strcmp (field_name + strlen (field_name) - 6,
406 "___XVN") != 0)));
14f9c5c9
AS
407}
408
409
872c8b51
JB
410/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
411 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
412 and return its index. This function also handles fields whose name
413 have ___ suffixes because the compiler sometimes alters their name
414 by adding such a suffix to represent fields with certain constraints.
415 If the field could not be found, return a negative number if
416 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
417
418int
419ada_get_field_index (const struct type *type, const char *field_name,
420 int maybe_missing)
421{
422 int fieldno;
872c8b51
JB
423 struct type *struct_type = check_typedef ((struct type *) type);
424
425 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
426 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
427 return fieldno;
428
429 if (!maybe_missing)
323e0a4a 430 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 431 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
432
433 return -1;
434}
435
436/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
437
438int
d2e4a39e 439ada_name_prefix_len (const char *name)
14f9c5c9
AS
440{
441 if (name == NULL)
442 return 0;
d2e4a39e 443 else
14f9c5c9 444 {
d2e4a39e 445 const char *p = strstr (name, "___");
14f9c5c9 446 if (p == NULL)
4c4b4cd2 447 return strlen (name);
14f9c5c9 448 else
4c4b4cd2 449 return p - name;
14f9c5c9
AS
450 }
451}
452
4c4b4cd2
PH
453/* Return non-zero if SUFFIX is a suffix of STR.
454 Return zero if STR is null. */
455
14f9c5c9 456static int
d2e4a39e 457is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
458{
459 int len1, len2;
460 if (str == NULL)
461 return 0;
462 len1 = strlen (str);
463 len2 = strlen (suffix);
4c4b4cd2 464 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
465}
466
4c4b4cd2
PH
467/* The contents of value VAL, treated as a value of type TYPE. The
468 result is an lval in memory if VAL is. */
14f9c5c9 469
d2e4a39e 470static struct value *
4c4b4cd2 471coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 472{
61ee279c 473 type = ada_check_typedef (type);
df407dfe 474 if (value_type (val) == type)
4c4b4cd2 475 return val;
d2e4a39e 476 else
14f9c5c9 477 {
4c4b4cd2
PH
478 struct value *result;
479
480 /* Make sure that the object size is not unreasonable before
481 trying to allocate some memory for it. */
714e53ab 482 check_size (type);
4c4b4cd2
PH
483
484 result = allocate_value (type);
74bcbdf3 485 set_value_component_location (result, val);
9bbda503
AC
486 set_value_bitsize (result, value_bitsize (val));
487 set_value_bitpos (result, value_bitpos (val));
74bcbdf3 488 VALUE_ADDRESS (result) += value_offset (val);
d69fe07e 489 if (value_lazy (val)
df407dfe 490 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
dfa52d88 491 set_value_lazy (result, 1);
d2e4a39e 492 else
0fd88904 493 memcpy (value_contents_raw (result), value_contents (val),
4c4b4cd2 494 TYPE_LENGTH (type));
14f9c5c9
AS
495 return result;
496 }
497}
498
fc1a4b47
AC
499static const gdb_byte *
500cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
501{
502 if (valaddr == NULL)
503 return NULL;
504 else
505 return valaddr + offset;
506}
507
508static CORE_ADDR
ebf56fd3 509cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
510{
511 if (address == 0)
512 return 0;
d2e4a39e 513 else
14f9c5c9
AS
514 return address + offset;
515}
516
4c4b4cd2
PH
517/* Issue a warning (as for the definition of warning in utils.c, but
518 with exactly one argument rather than ...), unless the limit on the
519 number of warnings has passed during the evaluation of the current
520 expression. */
a2249542 521
77109804
AC
522/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
523 provided by "complaint". */
524static void lim_warning (const char *format, ...) ATTR_FORMAT (printf, 1, 2);
525
14f9c5c9 526static void
a2249542 527lim_warning (const char *format, ...)
14f9c5c9 528{
a2249542
MK
529 va_list args;
530 va_start (args, format);
531
4c4b4cd2
PH
532 warnings_issued += 1;
533 if (warnings_issued <= warning_limit)
a2249542
MK
534 vwarning (format, args);
535
536 va_end (args);
4c4b4cd2
PH
537}
538
714e53ab
PH
539/* Issue an error if the size of an object of type T is unreasonable,
540 i.e. if it would be a bad idea to allocate a value of this type in
541 GDB. */
542
543static void
544check_size (const struct type *type)
545{
546 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 547 error (_("object size is larger than varsize-limit"));
714e53ab
PH
548}
549
550
c3e5cd34
PH
551/* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
552 gdbtypes.h, but some of the necessary definitions in that file
553 seem to have gone missing. */
554
555/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 556static LONGEST
c3e5cd34 557max_of_size (int size)
4c4b4cd2 558{
76a01679
JB
559 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
560 return top_bit | (top_bit - 1);
4c4b4cd2
PH
561}
562
c3e5cd34 563/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 564static LONGEST
c3e5cd34 565min_of_size (int size)
4c4b4cd2 566{
c3e5cd34 567 return -max_of_size (size) - 1;
4c4b4cd2
PH
568}
569
c3e5cd34 570/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 571static ULONGEST
c3e5cd34 572umax_of_size (int size)
4c4b4cd2 573{
76a01679
JB
574 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
575 return top_bit | (top_bit - 1);
4c4b4cd2
PH
576}
577
c3e5cd34
PH
578/* Maximum value of integral type T, as a signed quantity. */
579static LONGEST
580max_of_type (struct type *t)
4c4b4cd2 581{
c3e5cd34
PH
582 if (TYPE_UNSIGNED (t))
583 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
584 else
585 return max_of_size (TYPE_LENGTH (t));
586}
587
588/* Minimum value of integral type T, as a signed quantity. */
589static LONGEST
590min_of_type (struct type *t)
591{
592 if (TYPE_UNSIGNED (t))
593 return 0;
594 else
595 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
596}
597
598/* The largest value in the domain of TYPE, a discrete type, as an integer. */
690cc4eb 599static LONGEST
4c4b4cd2
PH
600discrete_type_high_bound (struct type *type)
601{
76a01679 602 switch (TYPE_CODE (type))
4c4b4cd2
PH
603 {
604 case TYPE_CODE_RANGE:
690cc4eb 605 return TYPE_HIGH_BOUND (type);
4c4b4cd2 606 case TYPE_CODE_ENUM:
690cc4eb
PH
607 return TYPE_FIELD_BITPOS (type, TYPE_NFIELDS (type) - 1);
608 case TYPE_CODE_BOOL:
609 return 1;
610 case TYPE_CODE_CHAR:
76a01679 611 case TYPE_CODE_INT:
690cc4eb 612 return max_of_type (type);
4c4b4cd2 613 default:
323e0a4a 614 error (_("Unexpected type in discrete_type_high_bound."));
4c4b4cd2
PH
615 }
616}
617
618/* The largest value in the domain of TYPE, a discrete type, as an integer. */
690cc4eb 619static LONGEST
4c4b4cd2
PH
620discrete_type_low_bound (struct type *type)
621{
76a01679 622 switch (TYPE_CODE (type))
4c4b4cd2
PH
623 {
624 case TYPE_CODE_RANGE:
690cc4eb 625 return TYPE_LOW_BOUND (type);
4c4b4cd2 626 case TYPE_CODE_ENUM:
690cc4eb
PH
627 return TYPE_FIELD_BITPOS (type, 0);
628 case TYPE_CODE_BOOL:
629 return 0;
630 case TYPE_CODE_CHAR:
76a01679 631 case TYPE_CODE_INT:
690cc4eb 632 return min_of_type (type);
4c4b4cd2 633 default:
323e0a4a 634 error (_("Unexpected type in discrete_type_low_bound."));
4c4b4cd2
PH
635 }
636}
637
638/* The identity on non-range types. For range types, the underlying
76a01679 639 non-range scalar type. */
4c4b4cd2
PH
640
641static struct type *
642base_type (struct type *type)
643{
644 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
645 {
76a01679
JB
646 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
647 return type;
4c4b4cd2
PH
648 type = TYPE_TARGET_TYPE (type);
649 }
650 return type;
14f9c5c9 651}
4c4b4cd2 652\f
76a01679 653
4c4b4cd2 654 /* Language Selection */
14f9c5c9
AS
655
656/* If the main program is in Ada, return language_ada, otherwise return LANG
657 (the main program is in Ada iif the adainit symbol is found).
658
4c4b4cd2 659 MAIN_PST is not used. */
d2e4a39e 660
14f9c5c9 661enum language
d2e4a39e 662ada_update_initial_language (enum language lang,
4c4b4cd2 663 struct partial_symtab *main_pst)
14f9c5c9 664{
d2e4a39e 665 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
4c4b4cd2
PH
666 (struct objfile *) NULL) != NULL)
667 return language_ada;
14f9c5c9
AS
668
669 return lang;
670}
96d887e8
PH
671
672/* If the main procedure is written in Ada, then return its name.
673 The result is good until the next call. Return NULL if the main
674 procedure doesn't appear to be in Ada. */
675
676char *
677ada_main_name (void)
678{
679 struct minimal_symbol *msym;
f9bc20b9 680 static char *main_program_name = NULL;
6c038f32 681
96d887e8
PH
682 /* For Ada, the name of the main procedure is stored in a specific
683 string constant, generated by the binder. Look for that symbol,
684 extract its address, and then read that string. If we didn't find
685 that string, then most probably the main procedure is not written
686 in Ada. */
687 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
688
689 if (msym != NULL)
690 {
f9bc20b9
JB
691 CORE_ADDR main_program_name_addr;
692 int err_code;
693
96d887e8
PH
694 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
695 if (main_program_name_addr == 0)
323e0a4a 696 error (_("Invalid address for Ada main program name."));
96d887e8 697
f9bc20b9
JB
698 xfree (main_program_name);
699 target_read_string (main_program_name_addr, &main_program_name,
700 1024, &err_code);
701
702 if (err_code != 0)
703 return NULL;
96d887e8
PH
704 return main_program_name;
705 }
706
707 /* The main procedure doesn't seem to be in Ada. */
708 return NULL;
709}
14f9c5c9 710\f
4c4b4cd2 711 /* Symbols */
d2e4a39e 712
4c4b4cd2
PH
713/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
714 of NULLs. */
14f9c5c9 715
d2e4a39e
AS
716const struct ada_opname_map ada_opname_table[] = {
717 {"Oadd", "\"+\"", BINOP_ADD},
718 {"Osubtract", "\"-\"", BINOP_SUB},
719 {"Omultiply", "\"*\"", BINOP_MUL},
720 {"Odivide", "\"/\"", BINOP_DIV},
721 {"Omod", "\"mod\"", BINOP_MOD},
722 {"Orem", "\"rem\"", BINOP_REM},
723 {"Oexpon", "\"**\"", BINOP_EXP},
724 {"Olt", "\"<\"", BINOP_LESS},
725 {"Ole", "\"<=\"", BINOP_LEQ},
726 {"Ogt", "\">\"", BINOP_GTR},
727 {"Oge", "\">=\"", BINOP_GEQ},
728 {"Oeq", "\"=\"", BINOP_EQUAL},
729 {"One", "\"/=\"", BINOP_NOTEQUAL},
730 {"Oand", "\"and\"", BINOP_BITWISE_AND},
731 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
732 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
733 {"Oconcat", "\"&\"", BINOP_CONCAT},
734 {"Oabs", "\"abs\"", UNOP_ABS},
735 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
736 {"Oadd", "\"+\"", UNOP_PLUS},
737 {"Osubtract", "\"-\"", UNOP_NEG},
738 {NULL, NULL}
14f9c5c9
AS
739};
740
4c4b4cd2
PH
741/* The "encoded" form of DECODED, according to GNAT conventions.
742 The result is valid until the next call to ada_encode. */
743
14f9c5c9 744char *
4c4b4cd2 745ada_encode (const char *decoded)
14f9c5c9 746{
4c4b4cd2
PH
747 static char *encoding_buffer = NULL;
748 static size_t encoding_buffer_size = 0;
d2e4a39e 749 const char *p;
14f9c5c9 750 int k;
d2e4a39e 751
4c4b4cd2 752 if (decoded == NULL)
14f9c5c9
AS
753 return NULL;
754
4c4b4cd2
PH
755 GROW_VECT (encoding_buffer, encoding_buffer_size,
756 2 * strlen (decoded) + 10);
14f9c5c9
AS
757
758 k = 0;
4c4b4cd2 759 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 760 {
cdc7bb92 761 if (*p == '.')
4c4b4cd2
PH
762 {
763 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
764 k += 2;
765 }
14f9c5c9 766 else if (*p == '"')
4c4b4cd2
PH
767 {
768 const struct ada_opname_map *mapping;
769
770 for (mapping = ada_opname_table;
1265e4aa
JB
771 mapping->encoded != NULL
772 && strncmp (mapping->decoded, p,
773 strlen (mapping->decoded)) != 0; mapping += 1)
4c4b4cd2
PH
774 ;
775 if (mapping->encoded == NULL)
323e0a4a 776 error (_("invalid Ada operator name: %s"), p);
4c4b4cd2
PH
777 strcpy (encoding_buffer + k, mapping->encoded);
778 k += strlen (mapping->encoded);
779 break;
780 }
d2e4a39e 781 else
4c4b4cd2
PH
782 {
783 encoding_buffer[k] = *p;
784 k += 1;
785 }
14f9c5c9
AS
786 }
787
4c4b4cd2
PH
788 encoding_buffer[k] = '\0';
789 return encoding_buffer;
14f9c5c9
AS
790}
791
792/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
793 quotes, unfolded, but with the quotes stripped away. Result good
794 to next call. */
795
d2e4a39e
AS
796char *
797ada_fold_name (const char *name)
14f9c5c9 798{
d2e4a39e 799 static char *fold_buffer = NULL;
14f9c5c9
AS
800 static size_t fold_buffer_size = 0;
801
802 int len = strlen (name);
d2e4a39e 803 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
804
805 if (name[0] == '\'')
806 {
d2e4a39e
AS
807 strncpy (fold_buffer, name + 1, len - 2);
808 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
809 }
810 else
811 {
812 int i;
813 for (i = 0; i <= len; i += 1)
4c4b4cd2 814 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
815 }
816
817 return fold_buffer;
818}
819
529cad9c
PH
820/* Return nonzero if C is either a digit or a lowercase alphabet character. */
821
822static int
823is_lower_alphanum (const char c)
824{
825 return (isdigit (c) || (isalpha (c) && islower (c)));
826}
827
29480c32
JB
828/* Remove either of these suffixes:
829 . .{DIGIT}+
830 . ${DIGIT}+
831 . ___{DIGIT}+
832 . __{DIGIT}+.
833 These are suffixes introduced by the compiler for entities such as
834 nested subprogram for instance, in order to avoid name clashes.
835 They do not serve any purpose for the debugger. */
836
837static void
838ada_remove_trailing_digits (const char *encoded, int *len)
839{
840 if (*len > 1 && isdigit (encoded[*len - 1]))
841 {
842 int i = *len - 2;
843 while (i > 0 && isdigit (encoded[i]))
844 i--;
845 if (i >= 0 && encoded[i] == '.')
846 *len = i;
847 else if (i >= 0 && encoded[i] == '$')
848 *len = i;
849 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
850 *len = i - 2;
851 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
852 *len = i - 1;
853 }
854}
855
856/* Remove the suffix introduced by the compiler for protected object
857 subprograms. */
858
859static void
860ada_remove_po_subprogram_suffix (const char *encoded, int *len)
861{
862 /* Remove trailing N. */
863
864 /* Protected entry subprograms are broken into two
865 separate subprograms: The first one is unprotected, and has
866 a 'N' suffix; the second is the protected version, and has
867 the 'P' suffix. The second calls the first one after handling
868 the protection. Since the P subprograms are internally generated,
869 we leave these names undecoded, giving the user a clue that this
870 entity is internal. */
871
872 if (*len > 1
873 && encoded[*len - 1] == 'N'
874 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
875 *len = *len - 1;
876}
877
878/* If ENCODED follows the GNAT entity encoding conventions, then return
879 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
880 replaced by ENCODED.
14f9c5c9 881
4c4b4cd2 882 The resulting string is valid until the next call of ada_decode.
29480c32 883 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
884 is returned. */
885
886const char *
887ada_decode (const char *encoded)
14f9c5c9
AS
888{
889 int i, j;
890 int len0;
d2e4a39e 891 const char *p;
4c4b4cd2 892 char *decoded;
14f9c5c9 893 int at_start_name;
4c4b4cd2
PH
894 static char *decoding_buffer = NULL;
895 static size_t decoding_buffer_size = 0;
d2e4a39e 896
29480c32
JB
897 /* The name of the Ada main procedure starts with "_ada_".
898 This prefix is not part of the decoded name, so skip this part
899 if we see this prefix. */
4c4b4cd2
PH
900 if (strncmp (encoded, "_ada_", 5) == 0)
901 encoded += 5;
14f9c5c9 902
29480c32
JB
903 /* If the name starts with '_', then it is not a properly encoded
904 name, so do not attempt to decode it. Similarly, if the name
905 starts with '<', the name should not be decoded. */
4c4b4cd2 906 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
907 goto Suppress;
908
4c4b4cd2 909 len0 = strlen (encoded);
4c4b4cd2 910
29480c32
JB
911 ada_remove_trailing_digits (encoded, &len0);
912 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 913
4c4b4cd2
PH
914 /* Remove the ___X.* suffix if present. Do not forget to verify that
915 the suffix is located before the current "end" of ENCODED. We want
916 to avoid re-matching parts of ENCODED that have previously been
917 marked as discarded (by decrementing LEN0). */
918 p = strstr (encoded, "___");
919 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
920 {
921 if (p[3] == 'X')
4c4b4cd2 922 len0 = p - encoded;
14f9c5c9 923 else
4c4b4cd2 924 goto Suppress;
14f9c5c9 925 }
4c4b4cd2 926
29480c32
JB
927 /* Remove any trailing TKB suffix. It tells us that this symbol
928 is for the body of a task, but that information does not actually
929 appear in the decoded name. */
930
4c4b4cd2 931 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
14f9c5c9 932 len0 -= 3;
76a01679 933
29480c32
JB
934 /* Remove trailing "B" suffixes. */
935 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
936
4c4b4cd2 937 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
14f9c5c9
AS
938 len0 -= 1;
939
4c4b4cd2 940 /* Make decoded big enough for possible expansion by operator name. */
29480c32 941
4c4b4cd2
PH
942 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
943 decoded = decoding_buffer;
14f9c5c9 944
29480c32
JB
945 /* Remove trailing __{digit}+ or trailing ${digit}+. */
946
4c4b4cd2 947 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 948 {
4c4b4cd2
PH
949 i = len0 - 2;
950 while ((i >= 0 && isdigit (encoded[i]))
951 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
952 i -= 1;
953 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
954 len0 = i - 1;
955 else if (encoded[i] == '$')
956 len0 = i;
d2e4a39e 957 }
14f9c5c9 958
29480c32
JB
959 /* The first few characters that are not alphabetic are not part
960 of any encoding we use, so we can copy them over verbatim. */
961
4c4b4cd2
PH
962 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
963 decoded[j] = encoded[i];
14f9c5c9
AS
964
965 at_start_name = 1;
966 while (i < len0)
967 {
29480c32 968 /* Is this a symbol function? */
4c4b4cd2
PH
969 if (at_start_name && encoded[i] == 'O')
970 {
971 int k;
972 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
973 {
974 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
975 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
976 op_len - 1) == 0)
977 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
978 {
979 strcpy (decoded + j, ada_opname_table[k].decoded);
980 at_start_name = 0;
981 i += op_len;
982 j += strlen (ada_opname_table[k].decoded);
983 break;
984 }
985 }
986 if (ada_opname_table[k].encoded != NULL)
987 continue;
988 }
14f9c5c9
AS
989 at_start_name = 0;
990
529cad9c
PH
991 /* Replace "TK__" with "__", which will eventually be translated
992 into "." (just below). */
993
4c4b4cd2
PH
994 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
995 i += 2;
529cad9c 996
29480c32
JB
997 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
998 be translated into "." (just below). These are internal names
999 generated for anonymous blocks inside which our symbol is nested. */
1000
1001 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1002 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1003 && isdigit (encoded [i+4]))
1004 {
1005 int k = i + 5;
1006
1007 while (k < len0 && isdigit (encoded[k]))
1008 k++; /* Skip any extra digit. */
1009
1010 /* Double-check that the "__B_{DIGITS}+" sequence we found
1011 is indeed followed by "__". */
1012 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1013 i = k;
1014 }
1015
529cad9c
PH
1016 /* Remove _E{DIGITS}+[sb] */
1017
1018 /* Just as for protected object subprograms, there are 2 categories
1019 of subprograms created by the compiler for each entry. The first
1020 one implements the actual entry code, and has a suffix following
1021 the convention above; the second one implements the barrier and
1022 uses the same convention as above, except that the 'E' is replaced
1023 by a 'B'.
1024
1025 Just as above, we do not decode the name of barrier functions
1026 to give the user a clue that the code he is debugging has been
1027 internally generated. */
1028
1029 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1030 && isdigit (encoded[i+2]))
1031 {
1032 int k = i + 3;
1033
1034 while (k < len0 && isdigit (encoded[k]))
1035 k++;
1036
1037 if (k < len0
1038 && (encoded[k] == 'b' || encoded[k] == 's'))
1039 {
1040 k++;
1041 /* Just as an extra precaution, make sure that if this
1042 suffix is followed by anything else, it is a '_'.
1043 Otherwise, we matched this sequence by accident. */
1044 if (k == len0
1045 || (k < len0 && encoded[k] == '_'))
1046 i = k;
1047 }
1048 }
1049
1050 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1051 the GNAT front-end in protected object subprograms. */
1052
1053 if (i < len0 + 3
1054 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1055 {
1056 /* Backtrack a bit up until we reach either the begining of
1057 the encoded name, or "__". Make sure that we only find
1058 digits or lowercase characters. */
1059 const char *ptr = encoded + i - 1;
1060
1061 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1062 ptr--;
1063 if (ptr < encoded
1064 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1065 i++;
1066 }
1067
4c4b4cd2
PH
1068 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1069 {
29480c32
JB
1070 /* This is a X[bn]* sequence not separated from the previous
1071 part of the name with a non-alpha-numeric character (in other
1072 words, immediately following an alpha-numeric character), then
1073 verify that it is placed at the end of the encoded name. If
1074 not, then the encoding is not valid and we should abort the
1075 decoding. Otherwise, just skip it, it is used in body-nested
1076 package names. */
4c4b4cd2
PH
1077 do
1078 i += 1;
1079 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1080 if (i < len0)
1081 goto Suppress;
1082 }
cdc7bb92 1083 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1084 {
29480c32 1085 /* Replace '__' by '.'. */
4c4b4cd2
PH
1086 decoded[j] = '.';
1087 at_start_name = 1;
1088 i += 2;
1089 j += 1;
1090 }
14f9c5c9 1091 else
4c4b4cd2 1092 {
29480c32
JB
1093 /* It's a character part of the decoded name, so just copy it
1094 over. */
4c4b4cd2
PH
1095 decoded[j] = encoded[i];
1096 i += 1;
1097 j += 1;
1098 }
14f9c5c9 1099 }
4c4b4cd2 1100 decoded[j] = '\000';
14f9c5c9 1101
29480c32
JB
1102 /* Decoded names should never contain any uppercase character.
1103 Double-check this, and abort the decoding if we find one. */
1104
4c4b4cd2
PH
1105 for (i = 0; decoded[i] != '\0'; i += 1)
1106 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1107 goto Suppress;
1108
4c4b4cd2
PH
1109 if (strcmp (decoded, encoded) == 0)
1110 return encoded;
1111 else
1112 return decoded;
14f9c5c9
AS
1113
1114Suppress:
4c4b4cd2
PH
1115 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1116 decoded = decoding_buffer;
1117 if (encoded[0] == '<')
1118 strcpy (decoded, encoded);
14f9c5c9 1119 else
88c15c34 1120 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1121 return decoded;
1122
1123}
1124
1125/* Table for keeping permanent unique copies of decoded names. Once
1126 allocated, names in this table are never released. While this is a
1127 storage leak, it should not be significant unless there are massive
1128 changes in the set of decoded names in successive versions of a
1129 symbol table loaded during a single session. */
1130static struct htab *decoded_names_store;
1131
1132/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1133 in the language-specific part of GSYMBOL, if it has not been
1134 previously computed. Tries to save the decoded name in the same
1135 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1136 in any case, the decoded symbol has a lifetime at least that of
1137 GSYMBOL).
1138 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1139 const, but nevertheless modified to a semantically equivalent form
1140 when a decoded name is cached in it.
76a01679 1141*/
4c4b4cd2 1142
76a01679
JB
1143char *
1144ada_decode_symbol (const struct general_symbol_info *gsymbol)
4c4b4cd2 1145{
76a01679 1146 char **resultp =
4c4b4cd2
PH
1147 (char **) &gsymbol->language_specific.cplus_specific.demangled_name;
1148 if (*resultp == NULL)
1149 {
1150 const char *decoded = ada_decode (gsymbol->name);
714835d5 1151 if (gsymbol->obj_section != NULL)
76a01679 1152 {
714835d5
UW
1153 struct objfile *objf = gsymbol->obj_section->objfile;
1154 *resultp = obsavestring (decoded, strlen (decoded),
1155 &objf->objfile_obstack);
76a01679 1156 }
4c4b4cd2 1157 /* Sometimes, we can't find a corresponding objfile, in which
76a01679
JB
1158 case, we put the result on the heap. Since we only decode
1159 when needed, we hope this usually does not cause a
1160 significant memory leak (FIXME). */
4c4b4cd2 1161 if (*resultp == NULL)
76a01679
JB
1162 {
1163 char **slot = (char **) htab_find_slot (decoded_names_store,
1164 decoded, INSERT);
1165 if (*slot == NULL)
1166 *slot = xstrdup (decoded);
1167 *resultp = *slot;
1168 }
4c4b4cd2 1169 }
14f9c5c9 1170
4c4b4cd2
PH
1171 return *resultp;
1172}
76a01679 1173
2c0b251b 1174static char *
76a01679 1175ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1176{
1177 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1178}
1179
1180/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
4c4b4cd2
PH
1181 suffixes that encode debugging information or leading _ada_ on
1182 SYM_NAME (see is_name_suffix commentary for the debugging
1183 information that is ignored). If WILD, then NAME need only match a
1184 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1185 either argument is NULL. */
14f9c5c9 1186
2c0b251b 1187static int
d2e4a39e 1188ada_match_name (const char *sym_name, const char *name, int wild)
14f9c5c9
AS
1189{
1190 if (sym_name == NULL || name == NULL)
1191 return 0;
1192 else if (wild)
1193 return wild_match (name, strlen (name), sym_name);
d2e4a39e
AS
1194 else
1195 {
1196 int len_name = strlen (name);
4c4b4cd2
PH
1197 return (strncmp (sym_name, name, len_name) == 0
1198 && is_name_suffix (sym_name + len_name))
1199 || (strncmp (sym_name, "_ada_", 5) == 0
1200 && strncmp (sym_name + 5, name, len_name) == 0
1201 && is_name_suffix (sym_name + len_name + 5));
d2e4a39e 1202 }
14f9c5c9 1203}
14f9c5c9 1204\f
d2e4a39e 1205
4c4b4cd2 1206 /* Arrays */
14f9c5c9 1207
4c4b4cd2 1208/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1209
d2e4a39e
AS
1210static char *bound_name[] = {
1211 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1212 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1213};
1214
1215/* Maximum number of array dimensions we are prepared to handle. */
1216
4c4b4cd2 1217#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1218
4c4b4cd2 1219/* Like modify_field, but allows bitpos > wordlength. */
14f9c5c9
AS
1220
1221static void
ebf56fd3 1222modify_general_field (char *addr, LONGEST fieldval, int bitpos, int bitsize)
14f9c5c9 1223{
4c4b4cd2 1224 modify_field (addr + bitpos / 8, fieldval, bitpos % 8, bitsize);
14f9c5c9
AS
1225}
1226
1227
4c4b4cd2
PH
1228/* The desc_* routines return primitive portions of array descriptors
1229 (fat pointers). */
14f9c5c9
AS
1230
1231/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1232 level of indirection, if needed. */
1233
d2e4a39e
AS
1234static struct type *
1235desc_base_type (struct type *type)
14f9c5c9
AS
1236{
1237 if (type == NULL)
1238 return NULL;
61ee279c 1239 type = ada_check_typedef (type);
1265e4aa
JB
1240 if (type != NULL
1241 && (TYPE_CODE (type) == TYPE_CODE_PTR
1242 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1243 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1244 else
1245 return type;
1246}
1247
4c4b4cd2
PH
1248/* True iff TYPE indicates a "thin" array pointer type. */
1249
14f9c5c9 1250static int
d2e4a39e 1251is_thin_pntr (struct type *type)
14f9c5c9 1252{
d2e4a39e 1253 return
14f9c5c9
AS
1254 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1255 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1256}
1257
4c4b4cd2
PH
1258/* The descriptor type for thin pointer type TYPE. */
1259
d2e4a39e
AS
1260static struct type *
1261thin_descriptor_type (struct type *type)
14f9c5c9 1262{
d2e4a39e 1263 struct type *base_type = desc_base_type (type);
14f9c5c9
AS
1264 if (base_type == NULL)
1265 return NULL;
1266 if (is_suffix (ada_type_name (base_type), "___XVE"))
1267 return base_type;
d2e4a39e 1268 else
14f9c5c9 1269 {
d2e4a39e 1270 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
14f9c5c9 1271 if (alt_type == NULL)
4c4b4cd2 1272 return base_type;
14f9c5c9 1273 else
4c4b4cd2 1274 return alt_type;
14f9c5c9
AS
1275 }
1276}
1277
4c4b4cd2
PH
1278/* A pointer to the array data for thin-pointer value VAL. */
1279
d2e4a39e
AS
1280static struct value *
1281thin_data_pntr (struct value *val)
14f9c5c9 1282{
df407dfe 1283 struct type *type = value_type (val);
14f9c5c9 1284 if (TYPE_CODE (type) == TYPE_CODE_PTR)
d2e4a39e 1285 return value_cast (desc_data_type (thin_descriptor_type (type)),
4c4b4cd2 1286 value_copy (val));
d2e4a39e 1287 else
14f9c5c9 1288 return value_from_longest (desc_data_type (thin_descriptor_type (type)),
df407dfe 1289 VALUE_ADDRESS (val) + value_offset (val));
14f9c5c9
AS
1290}
1291
4c4b4cd2
PH
1292/* True iff TYPE indicates a "thick" array pointer type. */
1293
14f9c5c9 1294static int
d2e4a39e 1295is_thick_pntr (struct type *type)
14f9c5c9
AS
1296{
1297 type = desc_base_type (type);
1298 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1299 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1300}
1301
4c4b4cd2
PH
1302/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1303 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1304
d2e4a39e
AS
1305static struct type *
1306desc_bounds_type (struct type *type)
14f9c5c9 1307{
d2e4a39e 1308 struct type *r;
14f9c5c9
AS
1309
1310 type = desc_base_type (type);
1311
1312 if (type == NULL)
1313 return NULL;
1314 else if (is_thin_pntr (type))
1315 {
1316 type = thin_descriptor_type (type);
1317 if (type == NULL)
4c4b4cd2 1318 return NULL;
14f9c5c9
AS
1319 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1320 if (r != NULL)
61ee279c 1321 return ada_check_typedef (r);
14f9c5c9
AS
1322 }
1323 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1324 {
1325 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1326 if (r != NULL)
61ee279c 1327 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1328 }
1329 return NULL;
1330}
1331
1332/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1333 one, a pointer to its bounds data. Otherwise NULL. */
1334
d2e4a39e
AS
1335static struct value *
1336desc_bounds (struct value *arr)
14f9c5c9 1337{
df407dfe 1338 struct type *type = ada_check_typedef (value_type (arr));
d2e4a39e 1339 if (is_thin_pntr (type))
14f9c5c9 1340 {
d2e4a39e 1341 struct type *bounds_type =
4c4b4cd2 1342 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1343 LONGEST addr;
1344
4cdfadb1 1345 if (bounds_type == NULL)
323e0a4a 1346 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1347
1348 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1349 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1350 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1351 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1352 addr = value_as_long (arr);
d2e4a39e 1353 else
df407dfe 1354 addr = VALUE_ADDRESS (arr) + value_offset (arr);
14f9c5c9 1355
d2e4a39e 1356 return
4c4b4cd2
PH
1357 value_from_longest (lookup_pointer_type (bounds_type),
1358 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1359 }
1360
1361 else if (is_thick_pntr (type))
d2e4a39e 1362 return value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
323e0a4a 1363 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1364 else
1365 return NULL;
1366}
1367
4c4b4cd2
PH
1368/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1369 position of the field containing the address of the bounds data. */
1370
14f9c5c9 1371static int
d2e4a39e 1372fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1373{
1374 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1375}
1376
1377/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1378 size of the field containing the address of the bounds data. */
1379
14f9c5c9 1380static int
d2e4a39e 1381fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1382{
1383 type = desc_base_type (type);
1384
d2e4a39e 1385 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1386 return TYPE_FIELD_BITSIZE (type, 1);
1387 else
61ee279c 1388 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1389}
1390
4c4b4cd2 1391/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
14f9c5c9 1392 pointer to one, the type of its array data (a
4c4b4cd2
PH
1393 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1394 ada_type_of_array to get an array type with bounds data. */
1395
d2e4a39e
AS
1396static struct type *
1397desc_data_type (struct type *type)
14f9c5c9
AS
1398{
1399 type = desc_base_type (type);
1400
4c4b4cd2 1401 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1402 if (is_thin_pntr (type))
d2e4a39e
AS
1403 return lookup_pointer_type
1404 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1)));
14f9c5c9
AS
1405 else if (is_thick_pntr (type))
1406 return lookup_struct_elt_type (type, "P_ARRAY", 1);
1407 else
1408 return NULL;
1409}
1410
1411/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1412 its array data. */
4c4b4cd2 1413
d2e4a39e
AS
1414static struct value *
1415desc_data (struct value *arr)
14f9c5c9 1416{
df407dfe 1417 struct type *type = value_type (arr);
14f9c5c9
AS
1418 if (is_thin_pntr (type))
1419 return thin_data_pntr (arr);
1420 else if (is_thick_pntr (type))
d2e4a39e 1421 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1422 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1423 else
1424 return NULL;
1425}
1426
1427
1428/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1429 position of the field containing the address of the data. */
1430
14f9c5c9 1431static int
d2e4a39e 1432fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1433{
1434 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1435}
1436
1437/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1438 size of the field containing the address of the data. */
1439
14f9c5c9 1440static int
d2e4a39e 1441fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1442{
1443 type = desc_base_type (type);
1444
1445 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1446 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1447 else
14f9c5c9
AS
1448 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1449}
1450
4c4b4cd2 1451/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1452 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1453 bound, if WHICH is 1. The first bound is I=1. */
1454
d2e4a39e
AS
1455static struct value *
1456desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1457{
d2e4a39e 1458 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1459 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1460}
1461
1462/* If BOUNDS is an array-bounds structure type, return the bit position
1463 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1464 bound, if WHICH is 1. The first bound is I=1. */
1465
14f9c5c9 1466static int
d2e4a39e 1467desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1468{
d2e4a39e 1469 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1470}
1471
1472/* If BOUNDS is an array-bounds structure type, return the bit field size
1473 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1474 bound, if WHICH is 1. The first bound is I=1. */
1475
76a01679 1476static int
d2e4a39e 1477desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1478{
1479 type = desc_base_type (type);
1480
d2e4a39e
AS
1481 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1482 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1483 else
1484 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1485}
1486
1487/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1488 Ith bound (numbering from 1). Otherwise, NULL. */
1489
d2e4a39e
AS
1490static struct type *
1491desc_index_type (struct type *type, int i)
14f9c5c9
AS
1492{
1493 type = desc_base_type (type);
1494
1495 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1496 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1497 else
14f9c5c9
AS
1498 return NULL;
1499}
1500
4c4b4cd2
PH
1501/* The number of index positions in the array-bounds type TYPE.
1502 Return 0 if TYPE is NULL. */
1503
14f9c5c9 1504static int
d2e4a39e 1505desc_arity (struct type *type)
14f9c5c9
AS
1506{
1507 type = desc_base_type (type);
1508
1509 if (type != NULL)
1510 return TYPE_NFIELDS (type) / 2;
1511 return 0;
1512}
1513
4c4b4cd2
PH
1514/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1515 an array descriptor type (representing an unconstrained array
1516 type). */
1517
76a01679
JB
1518static int
1519ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1520{
1521 if (type == NULL)
1522 return 0;
61ee279c 1523 type = ada_check_typedef (type);
4c4b4cd2 1524 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1525 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1526}
1527
52ce6436
PH
1528/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1529 * to one. */
1530
2c0b251b 1531static int
52ce6436
PH
1532ada_is_array_type (struct type *type)
1533{
1534 while (type != NULL
1535 && (TYPE_CODE (type) == TYPE_CODE_PTR
1536 || TYPE_CODE (type) == TYPE_CODE_REF))
1537 type = TYPE_TARGET_TYPE (type);
1538 return ada_is_direct_array_type (type);
1539}
1540
4c4b4cd2 1541/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1542
14f9c5c9 1543int
4c4b4cd2 1544ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1545{
1546 if (type == NULL)
1547 return 0;
61ee279c 1548 type = ada_check_typedef (type);
14f9c5c9 1549 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2
PH
1550 || (TYPE_CODE (type) == TYPE_CODE_PTR
1551 && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY));
14f9c5c9
AS
1552}
1553
4c4b4cd2
PH
1554/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1555
14f9c5c9 1556int
4c4b4cd2 1557ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1558{
d2e4a39e 1559 struct type *data_type = desc_data_type (type);
14f9c5c9
AS
1560
1561 if (type == NULL)
1562 return 0;
61ee279c 1563 type = ada_check_typedef (type);
d2e4a39e 1564 return
14f9c5c9
AS
1565 data_type != NULL
1566 && ((TYPE_CODE (data_type) == TYPE_CODE_PTR
4c4b4cd2
PH
1567 && TYPE_TARGET_TYPE (data_type) != NULL
1568 && TYPE_CODE (TYPE_TARGET_TYPE (data_type)) == TYPE_CODE_ARRAY)
1265e4aa 1569 || TYPE_CODE (data_type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
1570 && desc_arity (desc_bounds_type (type)) > 0;
1571}
1572
1573/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1574 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1575 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1576 is still needed. */
1577
14f9c5c9 1578int
ebf56fd3 1579ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1580{
d2e4a39e 1581 return
14f9c5c9
AS
1582 type != NULL
1583 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1584 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1585 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1586 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1587}
1588
1589
4c4b4cd2 1590/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1591 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1592 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1593 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1594 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1595 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1596 a descriptor. */
d2e4a39e
AS
1597struct type *
1598ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1599{
df407dfe
AC
1600 if (ada_is_packed_array_type (value_type (arr)))
1601 return decode_packed_array_type (value_type (arr));
14f9c5c9 1602
df407dfe
AC
1603 if (!ada_is_array_descriptor_type (value_type (arr)))
1604 return value_type (arr);
d2e4a39e
AS
1605
1606 if (!bounds)
1607 return
df407dfe 1608 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr))));
14f9c5c9
AS
1609 else
1610 {
d2e4a39e 1611 struct type *elt_type;
14f9c5c9 1612 int arity;
d2e4a39e 1613 struct value *descriptor;
df407dfe 1614 struct objfile *objf = TYPE_OBJFILE (value_type (arr));
14f9c5c9 1615
df407dfe
AC
1616 elt_type = ada_array_element_type (value_type (arr), -1);
1617 arity = ada_array_arity (value_type (arr));
14f9c5c9 1618
d2e4a39e 1619 if (elt_type == NULL || arity == 0)
df407dfe 1620 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
1621
1622 descriptor = desc_bounds (arr);
d2e4a39e 1623 if (value_as_long (descriptor) == 0)
4c4b4cd2 1624 return NULL;
d2e4a39e 1625 while (arity > 0)
4c4b4cd2
PH
1626 {
1627 struct type *range_type = alloc_type (objf);
1628 struct type *array_type = alloc_type (objf);
1629 struct value *low = desc_one_bound (descriptor, arity, 0);
1630 struct value *high = desc_one_bound (descriptor, arity, 1);
1631 arity -= 1;
1632
df407dfe 1633 create_range_type (range_type, value_type (low),
529cad9c
PH
1634 longest_to_int (value_as_long (low)),
1635 longest_to_int (value_as_long (high)));
4c4b4cd2
PH
1636 elt_type = create_array_type (array_type, elt_type, range_type);
1637 }
14f9c5c9
AS
1638
1639 return lookup_pointer_type (elt_type);
1640 }
1641}
1642
1643/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
1644 Otherwise, returns either a standard GDB array with bounds set
1645 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1646 GDB array. Returns NULL if ARR is a null fat pointer. */
1647
d2e4a39e
AS
1648struct value *
1649ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 1650{
df407dfe 1651 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 1652 {
d2e4a39e 1653 struct type *arrType = ada_type_of_array (arr, 1);
14f9c5c9 1654 if (arrType == NULL)
4c4b4cd2 1655 return NULL;
14f9c5c9
AS
1656 return value_cast (arrType, value_copy (desc_data (arr)));
1657 }
df407dfe 1658 else if (ada_is_packed_array_type (value_type (arr)))
14f9c5c9
AS
1659 return decode_packed_array (arr);
1660 else
1661 return arr;
1662}
1663
1664/* If ARR does not represent an array, returns ARR unchanged.
1665 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
1666 be ARR itself if it already is in the proper form). */
1667
1668static struct value *
d2e4a39e 1669ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 1670{
df407dfe 1671 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 1672 {
d2e4a39e 1673 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
14f9c5c9 1674 if (arrVal == NULL)
323e0a4a 1675 error (_("Bounds unavailable for null array pointer."));
529cad9c 1676 check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
1677 return value_ind (arrVal);
1678 }
df407dfe 1679 else if (ada_is_packed_array_type (value_type (arr)))
14f9c5c9 1680 return decode_packed_array (arr);
d2e4a39e 1681 else
14f9c5c9
AS
1682 return arr;
1683}
1684
1685/* If TYPE represents a GNAT array type, return it translated to an
1686 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
1687 packing). For other types, is the identity. */
1688
d2e4a39e
AS
1689struct type *
1690ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 1691{
d2e4a39e 1692 struct value *mark = value_mark ();
6d84d3d8 1693 struct value *dummy = value_from_longest (builtin_type_int32, 0);
d2e4a39e 1694 struct type *result;
04624583 1695 deprecated_set_value_type (dummy, type);
14f9c5c9 1696 result = ada_type_of_array (dummy, 0);
4c4b4cd2 1697 value_free_to_mark (mark);
14f9c5c9
AS
1698 return result;
1699}
1700
4c4b4cd2
PH
1701/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1702
14f9c5c9 1703int
d2e4a39e 1704ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
1705{
1706 if (type == NULL)
1707 return 0;
4c4b4cd2 1708 type = desc_base_type (type);
61ee279c 1709 type = ada_check_typedef (type);
d2e4a39e 1710 return
14f9c5c9
AS
1711 ada_type_name (type) != NULL
1712 && strstr (ada_type_name (type), "___XP") != NULL;
1713}
1714
1715/* Given that TYPE is a standard GDB array type with all bounds filled
1716 in, and that the element size of its ultimate scalar constituents
1717 (that is, either its elements, or, if it is an array of arrays, its
1718 elements' elements, etc.) is *ELT_BITS, return an identical type,
1719 but with the bit sizes of its elements (and those of any
1720 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2
PH
1721 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1722 in bits. */
1723
d2e4a39e
AS
1724static struct type *
1725packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 1726{
d2e4a39e
AS
1727 struct type *new_elt_type;
1728 struct type *new_type;
14f9c5c9
AS
1729 LONGEST low_bound, high_bound;
1730
61ee279c 1731 type = ada_check_typedef (type);
14f9c5c9
AS
1732 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
1733 return type;
1734
1735 new_type = alloc_type (TYPE_OBJFILE (type));
61ee279c 1736 new_elt_type = packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
4c4b4cd2 1737 elt_bits);
262452ec 1738 create_array_type (new_type, new_elt_type, TYPE_INDEX_TYPE (type));
14f9c5c9
AS
1739 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
1740 TYPE_NAME (new_type) = ada_type_name (type);
1741
262452ec 1742 if (get_discrete_bounds (TYPE_INDEX_TYPE (type),
4c4b4cd2 1743 &low_bound, &high_bound) < 0)
14f9c5c9
AS
1744 low_bound = high_bound = 0;
1745 if (high_bound < low_bound)
1746 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 1747 else
14f9c5c9
AS
1748 {
1749 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 1750 TYPE_LENGTH (new_type) =
4c4b4cd2 1751 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
1752 }
1753
876cecd0 1754 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
1755 return new_type;
1756}
1757
4c4b4cd2
PH
1758/* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1759
d2e4a39e
AS
1760static struct type *
1761decode_packed_array_type (struct type *type)
1762{
4c4b4cd2 1763 struct symbol *sym;
d2e4a39e 1764 struct block **blocks;
727e3d2e
JB
1765 char *raw_name = ada_type_name (ada_check_typedef (type));
1766 char *name;
1767 char *tail;
d2e4a39e 1768 struct type *shadow_type;
14f9c5c9
AS
1769 long bits;
1770 int i, n;
1771
727e3d2e
JB
1772 if (!raw_name)
1773 raw_name = ada_type_name (desc_base_type (type));
1774
1775 if (!raw_name)
1776 return NULL;
1777
1778 name = (char *) alloca (strlen (raw_name) + 1);
1779 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
1780 type = desc_base_type (type);
1781
14f9c5c9
AS
1782 memcpy (name, raw_name, tail - raw_name);
1783 name[tail - raw_name] = '\000';
1784
4c4b4cd2
PH
1785 sym = standard_lookup (name, get_selected_block (0), VAR_DOMAIN);
1786 if (sym == NULL || SYMBOL_TYPE (sym) == NULL)
14f9c5c9 1787 {
323e0a4a 1788 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
1789 return NULL;
1790 }
4c4b4cd2 1791 shadow_type = SYMBOL_TYPE (sym);
cb249c71 1792 CHECK_TYPEDEF (shadow_type);
14f9c5c9
AS
1793
1794 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
1795 {
323e0a4a 1796 lim_warning (_("could not understand bounds information on packed array"));
14f9c5c9
AS
1797 return NULL;
1798 }
d2e4a39e 1799
14f9c5c9
AS
1800 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1801 {
4c4b4cd2 1802 lim_warning
323e0a4a 1803 (_("could not understand bit size information on packed array"));
14f9c5c9
AS
1804 return NULL;
1805 }
d2e4a39e 1806
14f9c5c9
AS
1807 return packed_array_type (shadow_type, &bits);
1808}
1809
4c4b4cd2 1810/* Given that ARR is a struct value *indicating a GNAT packed array,
14f9c5c9
AS
1811 returns a simple array that denotes that array. Its type is a
1812 standard GDB array type except that the BITSIZEs of the array
1813 target types are set to the number of bits in each element, and the
4c4b4cd2 1814 type length is set appropriately. */
14f9c5c9 1815
d2e4a39e
AS
1816static struct value *
1817decode_packed_array (struct value *arr)
14f9c5c9 1818{
4c4b4cd2 1819 struct type *type;
14f9c5c9 1820
4c4b4cd2 1821 arr = ada_coerce_ref (arr);
df407dfe 1822 if (TYPE_CODE (value_type (arr)) == TYPE_CODE_PTR)
4c4b4cd2
PH
1823 arr = ada_value_ind (arr);
1824
df407dfe 1825 type = decode_packed_array_type (value_type (arr));
14f9c5c9
AS
1826 if (type == NULL)
1827 {
323e0a4a 1828 error (_("can't unpack array"));
14f9c5c9
AS
1829 return NULL;
1830 }
61ee279c 1831
32c9a795
MD
1832 if (gdbarch_bits_big_endian (current_gdbarch)
1833 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
1834 {
1835 /* This is a (right-justified) modular type representing a packed
1836 array with no wrapper. In order to interpret the value through
1837 the (left-justified) packed array type we just built, we must
1838 first left-justify it. */
1839 int bit_size, bit_pos;
1840 ULONGEST mod;
1841
df407dfe 1842 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
1843 bit_size = 0;
1844 while (mod > 0)
1845 {
1846 bit_size += 1;
1847 mod >>= 1;
1848 }
df407dfe 1849 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
1850 arr = ada_value_primitive_packed_val (arr, NULL,
1851 bit_pos / HOST_CHAR_BIT,
1852 bit_pos % HOST_CHAR_BIT,
1853 bit_size,
1854 type);
1855 }
1856
4c4b4cd2 1857 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
1858}
1859
1860
1861/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 1862 given in IND. ARR must be a simple array. */
14f9c5c9 1863
d2e4a39e
AS
1864static struct value *
1865value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
1866{
1867 int i;
1868 int bits, elt_off, bit_off;
1869 long elt_total_bit_offset;
d2e4a39e
AS
1870 struct type *elt_type;
1871 struct value *v;
14f9c5c9
AS
1872
1873 bits = 0;
1874 elt_total_bit_offset = 0;
df407dfe 1875 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 1876 for (i = 0; i < arity; i += 1)
14f9c5c9 1877 {
d2e4a39e 1878 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
1879 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
1880 error
323e0a4a 1881 (_("attempt to do packed indexing of something other than a packed array"));
14f9c5c9 1882 else
4c4b4cd2
PH
1883 {
1884 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
1885 LONGEST lowerbound, upperbound;
1886 LONGEST idx;
1887
1888 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
1889 {
323e0a4a 1890 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
1891 lowerbound = upperbound = 0;
1892 }
1893
3cb382c9 1894 idx = pos_atr (ind[i]);
4c4b4cd2 1895 if (idx < lowerbound || idx > upperbound)
323e0a4a 1896 lim_warning (_("packed array index %ld out of bounds"), (long) idx);
4c4b4cd2
PH
1897 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
1898 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 1899 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 1900 }
14f9c5c9
AS
1901 }
1902 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
1903 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
1904
1905 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 1906 bits, elt_type);
14f9c5c9
AS
1907 return v;
1908}
1909
4c4b4cd2 1910/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
1911
1912static int
d2e4a39e 1913has_negatives (struct type *type)
14f9c5c9 1914{
d2e4a39e
AS
1915 switch (TYPE_CODE (type))
1916 {
1917 default:
1918 return 0;
1919 case TYPE_CODE_INT:
1920 return !TYPE_UNSIGNED (type);
1921 case TYPE_CODE_RANGE:
1922 return TYPE_LOW_BOUND (type) < 0;
1923 }
14f9c5c9 1924}
d2e4a39e 1925
14f9c5c9
AS
1926
1927/* Create a new value of type TYPE from the contents of OBJ starting
1928 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1929 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
4c4b4cd2
PH
1930 assigning through the result will set the field fetched from.
1931 VALADDR is ignored unless OBJ is NULL, in which case,
1932 VALADDR+OFFSET must address the start of storage containing the
1933 packed value. The value returned in this case is never an lval.
1934 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
14f9c5c9 1935
d2e4a39e 1936struct value *
fc1a4b47 1937ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
a2bd3dcd 1938 long offset, int bit_offset, int bit_size,
4c4b4cd2 1939 struct type *type)
14f9c5c9 1940{
d2e4a39e 1941 struct value *v;
4c4b4cd2
PH
1942 int src, /* Index into the source area */
1943 targ, /* Index into the target area */
1944 srcBitsLeft, /* Number of source bits left to move */
1945 nsrc, ntarg, /* Number of source and target bytes */
1946 unusedLS, /* Number of bits in next significant
1947 byte of source that are unused */
1948 accumSize; /* Number of meaningful bits in accum */
1949 unsigned char *bytes; /* First byte containing data to unpack */
d2e4a39e 1950 unsigned char *unpacked;
4c4b4cd2 1951 unsigned long accum; /* Staging area for bits being transferred */
14f9c5c9
AS
1952 unsigned char sign;
1953 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
4c4b4cd2
PH
1954 /* Transmit bytes from least to most significant; delta is the direction
1955 the indices move. */
32c9a795 1956 int delta = gdbarch_bits_big_endian (current_gdbarch) ? -1 : 1;
14f9c5c9 1957
61ee279c 1958 type = ada_check_typedef (type);
14f9c5c9
AS
1959
1960 if (obj == NULL)
1961 {
1962 v = allocate_value (type);
d2e4a39e 1963 bytes = (unsigned char *) (valaddr + offset);
14f9c5c9 1964 }
9214ee5f 1965 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
14f9c5c9
AS
1966 {
1967 v = value_at (type,
df407dfe 1968 VALUE_ADDRESS (obj) + value_offset (obj) + offset);
d2e4a39e 1969 bytes = (unsigned char *) alloca (len);
14f9c5c9
AS
1970 read_memory (VALUE_ADDRESS (v), bytes, len);
1971 }
d2e4a39e 1972 else
14f9c5c9
AS
1973 {
1974 v = allocate_value (type);
0fd88904 1975 bytes = (unsigned char *) value_contents (obj) + offset;
14f9c5c9 1976 }
d2e4a39e
AS
1977
1978 if (obj != NULL)
14f9c5c9 1979 {
74bcbdf3
PA
1980 set_value_component_location (v, obj);
1981 VALUE_ADDRESS (v) += value_offset (obj) + offset;
9bbda503
AC
1982 set_value_bitpos (v, bit_offset + value_bitpos (obj));
1983 set_value_bitsize (v, bit_size);
df407dfe 1984 if (value_bitpos (v) >= HOST_CHAR_BIT)
4c4b4cd2
PH
1985 {
1986 VALUE_ADDRESS (v) += 1;
9bbda503 1987 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
4c4b4cd2 1988 }
14f9c5c9
AS
1989 }
1990 else
9bbda503 1991 set_value_bitsize (v, bit_size);
0fd88904 1992 unpacked = (unsigned char *) value_contents (v);
14f9c5c9
AS
1993
1994 srcBitsLeft = bit_size;
1995 nsrc = len;
1996 ntarg = TYPE_LENGTH (type);
1997 sign = 0;
1998 if (bit_size == 0)
1999 {
2000 memset (unpacked, 0, TYPE_LENGTH (type));
2001 return v;
2002 }
32c9a795 2003 else if (gdbarch_bits_big_endian (current_gdbarch))
14f9c5c9 2004 {
d2e4a39e 2005 src = len - 1;
1265e4aa
JB
2006 if (has_negatives (type)
2007 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2008 sign = ~0;
d2e4a39e
AS
2009
2010 unusedLS =
4c4b4cd2
PH
2011 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2012 % HOST_CHAR_BIT;
14f9c5c9
AS
2013
2014 switch (TYPE_CODE (type))
4c4b4cd2
PH
2015 {
2016 case TYPE_CODE_ARRAY:
2017 case TYPE_CODE_UNION:
2018 case TYPE_CODE_STRUCT:
2019 /* Non-scalar values must be aligned at a byte boundary... */
2020 accumSize =
2021 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2022 /* ... And are placed at the beginning (most-significant) bytes
2023 of the target. */
529cad9c 2024 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
0056e4d5 2025 ntarg = targ + 1;
4c4b4cd2
PH
2026 break;
2027 default:
2028 accumSize = 0;
2029 targ = TYPE_LENGTH (type) - 1;
2030 break;
2031 }
14f9c5c9 2032 }
d2e4a39e 2033 else
14f9c5c9
AS
2034 {
2035 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2036
2037 src = targ = 0;
2038 unusedLS = bit_offset;
2039 accumSize = 0;
2040
d2e4a39e 2041 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2042 sign = ~0;
14f9c5c9 2043 }
d2e4a39e 2044
14f9c5c9
AS
2045 accum = 0;
2046 while (nsrc > 0)
2047 {
2048 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2049 part of the value. */
d2e4a39e 2050 unsigned int unusedMSMask =
4c4b4cd2
PH
2051 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2052 1;
2053 /* Sign-extend bits for this byte. */
14f9c5c9 2054 unsigned int signMask = sign & ~unusedMSMask;
d2e4a39e 2055 accum |=
4c4b4cd2 2056 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2057 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2058 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2
PH
2059 {
2060 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2061 accumSize -= HOST_CHAR_BIT;
2062 accum >>= HOST_CHAR_BIT;
2063 ntarg -= 1;
2064 targ += delta;
2065 }
14f9c5c9
AS
2066 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2067 unusedLS = 0;
2068 nsrc -= 1;
2069 src += delta;
2070 }
2071 while (ntarg > 0)
2072 {
2073 accum |= sign << accumSize;
2074 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2075 accumSize -= HOST_CHAR_BIT;
2076 accum >>= HOST_CHAR_BIT;
2077 ntarg -= 1;
2078 targ += delta;
2079 }
2080
2081 return v;
2082}
d2e4a39e 2083
14f9c5c9
AS
2084/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2085 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2086 not overlap. */
14f9c5c9 2087static void
fc1a4b47 2088move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
0fd88904 2089 int src_offset, int n)
14f9c5c9
AS
2090{
2091 unsigned int accum, mask;
2092 int accum_bits, chunk_size;
2093
2094 target += targ_offset / HOST_CHAR_BIT;
2095 targ_offset %= HOST_CHAR_BIT;
2096 source += src_offset / HOST_CHAR_BIT;
2097 src_offset %= HOST_CHAR_BIT;
32c9a795 2098 if (gdbarch_bits_big_endian (current_gdbarch))
14f9c5c9
AS
2099 {
2100 accum = (unsigned char) *source;
2101 source += 1;
2102 accum_bits = HOST_CHAR_BIT - src_offset;
2103
d2e4a39e 2104 while (n > 0)
4c4b4cd2
PH
2105 {
2106 int unused_right;
2107 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2108 accum_bits += HOST_CHAR_BIT;
2109 source += 1;
2110 chunk_size = HOST_CHAR_BIT - targ_offset;
2111 if (chunk_size > n)
2112 chunk_size = n;
2113 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2114 mask = ((1 << chunk_size) - 1) << unused_right;
2115 *target =
2116 (*target & ~mask)
2117 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2118 n -= chunk_size;
2119 accum_bits -= chunk_size;
2120 target += 1;
2121 targ_offset = 0;
2122 }
14f9c5c9
AS
2123 }
2124 else
2125 {
2126 accum = (unsigned char) *source >> src_offset;
2127 source += 1;
2128 accum_bits = HOST_CHAR_BIT - src_offset;
2129
d2e4a39e 2130 while (n > 0)
4c4b4cd2
PH
2131 {
2132 accum = accum + ((unsigned char) *source << accum_bits);
2133 accum_bits += HOST_CHAR_BIT;
2134 source += 1;
2135 chunk_size = HOST_CHAR_BIT - targ_offset;
2136 if (chunk_size > n)
2137 chunk_size = n;
2138 mask = ((1 << chunk_size) - 1) << targ_offset;
2139 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2140 n -= chunk_size;
2141 accum_bits -= chunk_size;
2142 accum >>= chunk_size;
2143 target += 1;
2144 targ_offset = 0;
2145 }
14f9c5c9
AS
2146 }
2147}
2148
14f9c5c9
AS
2149/* Store the contents of FROMVAL into the location of TOVAL.
2150 Return a new value with the location of TOVAL and contents of
2151 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2152 floating-point or non-scalar types. */
14f9c5c9 2153
d2e4a39e
AS
2154static struct value *
2155ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2156{
df407dfe
AC
2157 struct type *type = value_type (toval);
2158 int bits = value_bitsize (toval);
14f9c5c9 2159
52ce6436
PH
2160 toval = ada_coerce_ref (toval);
2161 fromval = ada_coerce_ref (fromval);
2162
2163 if (ada_is_direct_array_type (value_type (toval)))
2164 toval = ada_coerce_to_simple_array (toval);
2165 if (ada_is_direct_array_type (value_type (fromval)))
2166 fromval = ada_coerce_to_simple_array (fromval);
2167
88e3b34b 2168 if (!deprecated_value_modifiable (toval))
323e0a4a 2169 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2170
d2e4a39e 2171 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2172 && bits > 0
d2e4a39e 2173 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2174 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2175 {
df407dfe
AC
2176 int len = (value_bitpos (toval)
2177 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2178 int from_size;
d2e4a39e
AS
2179 char *buffer = (char *) alloca (len);
2180 struct value *val;
52ce6436 2181 CORE_ADDR to_addr = VALUE_ADDRESS (toval) + value_offset (toval);
14f9c5c9
AS
2182
2183 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2184 fromval = value_cast (type, fromval);
14f9c5c9 2185
52ce6436 2186 read_memory (to_addr, buffer, len);
aced2898
PH
2187 from_size = value_bitsize (fromval);
2188 if (from_size == 0)
2189 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
32c9a795 2190 if (gdbarch_bits_big_endian (current_gdbarch))
df407dfe 2191 move_bits (buffer, value_bitpos (toval),
aced2898 2192 value_contents (fromval), from_size - bits, bits);
14f9c5c9 2193 else
0fd88904 2194 move_bits (buffer, value_bitpos (toval), value_contents (fromval),
4c4b4cd2 2195 0, bits);
52ce6436
PH
2196 write_memory (to_addr, buffer, len);
2197 if (deprecated_memory_changed_hook)
2198 deprecated_memory_changed_hook (to_addr, len);
2199
14f9c5c9 2200 val = value_copy (toval);
0fd88904 2201 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2202 TYPE_LENGTH (type));
04624583 2203 deprecated_set_value_type (val, type);
d2e4a39e 2204
14f9c5c9
AS
2205 return val;
2206 }
2207
2208 return value_assign (toval, fromval);
2209}
2210
2211
52ce6436
PH
2212/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2213 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2214 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2215 * COMPONENT, and not the inferior's memory. The current contents
2216 * of COMPONENT are ignored. */
2217static void
2218value_assign_to_component (struct value *container, struct value *component,
2219 struct value *val)
2220{
2221 LONGEST offset_in_container =
2222 (LONGEST) (VALUE_ADDRESS (component) + value_offset (component)
2223 - VALUE_ADDRESS (container) - value_offset (container));
2224 int bit_offset_in_container =
2225 value_bitpos (component) - value_bitpos (container);
2226 int bits;
2227
2228 val = value_cast (value_type (component), val);
2229
2230 if (value_bitsize (component) == 0)
2231 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2232 else
2233 bits = value_bitsize (component);
2234
32c9a795 2235 if (gdbarch_bits_big_endian (current_gdbarch))
52ce6436
PH
2236 move_bits (value_contents_writeable (container) + offset_in_container,
2237 value_bitpos (container) + bit_offset_in_container,
2238 value_contents (val),
2239 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2240 bits);
2241 else
2242 move_bits (value_contents_writeable (container) + offset_in_container,
2243 value_bitpos (container) + bit_offset_in_container,
2244 value_contents (val), 0, bits);
2245}
2246
4c4b4cd2
PH
2247/* The value of the element of array ARR at the ARITY indices given in IND.
2248 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2249 thereto. */
2250
d2e4a39e
AS
2251struct value *
2252ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2253{
2254 int k;
d2e4a39e
AS
2255 struct value *elt;
2256 struct type *elt_type;
14f9c5c9
AS
2257
2258 elt = ada_coerce_to_simple_array (arr);
2259
df407dfe 2260 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2261 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2262 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2263 return value_subscript_packed (elt, arity, ind);
2264
2265 for (k = 0; k < arity; k += 1)
2266 {
2267 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2268 error (_("too many subscripts (%d expected)"), k);
3cb382c9 2269 elt = value_subscript (elt, value_pos_atr (builtin_type_int32, ind[k]));
14f9c5c9
AS
2270 }
2271 return elt;
2272}
2273
2274/* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2275 value of the element of *ARR at the ARITY indices given in
4c4b4cd2 2276 IND. Does not read the entire array into memory. */
14f9c5c9 2277
2c0b251b 2278static struct value *
d2e4a39e 2279ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
4c4b4cd2 2280 struct value **ind)
14f9c5c9
AS
2281{
2282 int k;
2283
2284 for (k = 0; k < arity; k += 1)
2285 {
2286 LONGEST lwb, upb;
d2e4a39e 2287 struct value *idx;
14f9c5c9
AS
2288
2289 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2290 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2291 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2292 value_copy (arr));
14f9c5c9 2293 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
3cb382c9 2294 idx = value_pos_atr (builtin_type_int32, ind[k]);
4c4b4cd2 2295 if (lwb != 0)
89eef114
UW
2296 idx = value_binop (idx, value_from_longest (value_type (idx), lwb),
2297 BINOP_SUB);
2298
2299 arr = value_ptradd (arr, idx);
14f9c5c9
AS
2300 type = TYPE_TARGET_TYPE (type);
2301 }
2302
2303 return value_ind (arr);
2304}
2305
0b5d8877 2306/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
f5938064
JG
2307 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2308 elements starting at index LOW. The lower bound of this array is LOW, as
2309 per Ada rules. */
0b5d8877 2310static struct value *
f5938064
JG
2311ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2312 int low, int high)
0b5d8877 2313{
6c038f32 2314 CORE_ADDR base = value_as_address (array_ptr)
0b5d8877
PH
2315 + ((low - TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type)))
2316 * TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
6c038f32
PH
2317 struct type *index_type =
2318 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type)),
0b5d8877 2319 low, high);
6c038f32 2320 struct type *slice_type =
0b5d8877 2321 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
f5938064 2322 return value_at_lazy (slice_type, base);
0b5d8877
PH
2323}
2324
2325
2326static struct value *
2327ada_value_slice (struct value *array, int low, int high)
2328{
df407dfe 2329 struct type *type = value_type (array);
6c038f32 2330 struct type *index_type =
0b5d8877 2331 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
6c038f32 2332 struct type *slice_type =
0b5d8877 2333 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
6c038f32 2334 return value_cast (slice_type, value_slice (array, low, high - low + 1));
0b5d8877
PH
2335}
2336
14f9c5c9
AS
2337/* If type is a record type in the form of a standard GNAT array
2338 descriptor, returns the number of dimensions for type. If arr is a
2339 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2340 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2341
2342int
d2e4a39e 2343ada_array_arity (struct type *type)
14f9c5c9
AS
2344{
2345 int arity;
2346
2347 if (type == NULL)
2348 return 0;
2349
2350 type = desc_base_type (type);
2351
2352 arity = 0;
d2e4a39e 2353 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2354 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2355 else
2356 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2357 {
4c4b4cd2 2358 arity += 1;
61ee279c 2359 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2360 }
d2e4a39e 2361
14f9c5c9
AS
2362 return arity;
2363}
2364
2365/* If TYPE is a record type in the form of a standard GNAT array
2366 descriptor or a simple array type, returns the element type for
2367 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2368 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2369
d2e4a39e
AS
2370struct type *
2371ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2372{
2373 type = desc_base_type (type);
2374
d2e4a39e 2375 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2376 {
2377 int k;
d2e4a39e 2378 struct type *p_array_type;
14f9c5c9
AS
2379
2380 p_array_type = desc_data_type (type);
2381
2382 k = ada_array_arity (type);
2383 if (k == 0)
4c4b4cd2 2384 return NULL;
d2e4a39e 2385
4c4b4cd2 2386 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2387 if (nindices >= 0 && k > nindices)
4c4b4cd2 2388 k = nindices;
14f9c5c9 2389 p_array_type = TYPE_TARGET_TYPE (p_array_type);
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
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
PH
3764 {
3765 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3766 reserving sufficient space. */
3767 *sp -= len;
3768 if (gdbarch_frame_align_p (current_gdbarch))
3769 *sp = gdbarch_frame_align (current_gdbarch, *sp);
3770 VALUE_ADDRESS (val) = *sp;
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);
3778 VALUE_ADDRESS (val) = *sp;
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
990a07ab 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),
76a01679
JB
3874 VALUE_ADDRESS (ensure_lval (arr, sp)),
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),
4c4b4cd2
PH
3879 VALUE_ADDRESS (bounds),
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;
89eef114
UW
5565 val = value_ind (value_ptradd (valp,
5566 value_from_longest (builtin_type_int8, -1)));
4c4b4cd2
PH
5567 if (val == NULL)
5568 return 0;
03ee6b2e 5569 val = ada_value_struct_elt (val, "expanded_name", 1);
4c4b4cd2
PH
5570 if (val == NULL)
5571 return 0;
5572 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
5573 for (p = name; *p != '\0'; p += 1)
5574 if (isalpha (*p))
5575 *p = tolower (*p);
5576 args->name = name;
5577 return 0;
5578}
5579
5580/* The type name of the dynamic type denoted by the 'tag value TAG, as
5581 * a C string. */
5582
5583const char *
5584ada_tag_name (struct value *tag)
5585{
5586 struct tag_args args;
df407dfe 5587 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 5588 return NULL;
76a01679 5589 args.tag = tag;
4c4b4cd2
PH
5590 args.name = NULL;
5591 catch_errors (ada_tag_name_1, &args, NULL, RETURN_MASK_ALL);
5592 return args.name;
5593}
5594
5595/* The parent type of TYPE, or NULL if none. */
14f9c5c9 5596
d2e4a39e 5597struct type *
ebf56fd3 5598ada_parent_type (struct type *type)
14f9c5c9
AS
5599{
5600 int i;
5601
61ee279c 5602 type = ada_check_typedef (type);
14f9c5c9
AS
5603
5604 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5605 return NULL;
5606
5607 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5608 if (ada_is_parent_field (type, i))
0c1f74cf
JB
5609 {
5610 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
5611
5612 /* If the _parent field is a pointer, then dereference it. */
5613 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
5614 parent_type = TYPE_TARGET_TYPE (parent_type);
5615 /* If there is a parallel XVS type, get the actual base type. */
5616 parent_type = ada_get_base_type (parent_type);
5617
5618 return ada_check_typedef (parent_type);
5619 }
14f9c5c9
AS
5620
5621 return NULL;
5622}
5623
4c4b4cd2
PH
5624/* True iff field number FIELD_NUM of structure type TYPE contains the
5625 parent-type (inherited) fields of a derived type. Assumes TYPE is
5626 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
5627
5628int
ebf56fd3 5629ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 5630{
61ee279c 5631 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
4c4b4cd2
PH
5632 return (name != NULL
5633 && (strncmp (name, "PARENT", 6) == 0
5634 || strncmp (name, "_parent", 7) == 0));
14f9c5c9
AS
5635}
5636
4c4b4cd2 5637/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 5638 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 5639 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 5640 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 5641 structures. */
14f9c5c9
AS
5642
5643int
ebf56fd3 5644ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 5645{
d2e4a39e
AS
5646 const char *name = TYPE_FIELD_NAME (type, field_num);
5647 return (name != NULL
4c4b4cd2
PH
5648 && (strncmp (name, "PARENT", 6) == 0
5649 || strcmp (name, "REP") == 0
5650 || strncmp (name, "_parent", 7) == 0
5651 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
5652}
5653
4c4b4cd2
PH
5654/* True iff field number FIELD_NUM of structure or union type TYPE
5655 is a variant wrapper. Assumes TYPE is a structure type with at least
5656 FIELD_NUM+1 fields. */
14f9c5c9
AS
5657
5658int
ebf56fd3 5659ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 5660{
d2e4a39e 5661 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
14f9c5c9 5662 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 5663 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
5664 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
5665 == TYPE_CODE_UNION)));
14f9c5c9
AS
5666}
5667
5668/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 5669 whose discriminants are contained in the record type OUTER_TYPE,
14f9c5c9
AS
5670 returns the type of the controlling discriminant for the variant. */
5671
d2e4a39e 5672struct type *
ebf56fd3 5673ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 5674{
d2e4a39e 5675 char *name = ada_variant_discrim_name (var_type);
76a01679 5676 struct type *type =
4c4b4cd2 5677 ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
14f9c5c9 5678 if (type == NULL)
6d84d3d8 5679 return builtin_type_int32;
14f9c5c9
AS
5680 else
5681 return type;
5682}
5683
4c4b4cd2 5684/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 5685 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 5686 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
5687
5688int
ebf56fd3 5689ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 5690{
d2e4a39e 5691 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
5692 return (name != NULL && name[0] == 'O');
5693}
5694
5695/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
5696 returns the name of the discriminant controlling the variant.
5697 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 5698
d2e4a39e 5699char *
ebf56fd3 5700ada_variant_discrim_name (struct type *type0)
14f9c5c9 5701{
d2e4a39e 5702 static char *result = NULL;
14f9c5c9 5703 static size_t result_len = 0;
d2e4a39e
AS
5704 struct type *type;
5705 const char *name;
5706 const char *discrim_end;
5707 const char *discrim_start;
14f9c5c9
AS
5708
5709 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
5710 type = TYPE_TARGET_TYPE (type0);
5711 else
5712 type = type0;
5713
5714 name = ada_type_name (type);
5715
5716 if (name == NULL || name[0] == '\000')
5717 return "";
5718
5719 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
5720 discrim_end -= 1)
5721 {
4c4b4cd2
PH
5722 if (strncmp (discrim_end, "___XVN", 6) == 0)
5723 break;
14f9c5c9
AS
5724 }
5725 if (discrim_end == name)
5726 return "";
5727
d2e4a39e 5728 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
5729 discrim_start -= 1)
5730 {
d2e4a39e 5731 if (discrim_start == name + 1)
4c4b4cd2 5732 return "";
76a01679 5733 if ((discrim_start > name + 3
4c4b4cd2
PH
5734 && strncmp (discrim_start - 3, "___", 3) == 0)
5735 || discrim_start[-1] == '.')
5736 break;
14f9c5c9
AS
5737 }
5738
5739 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
5740 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 5741 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
5742 return result;
5743}
5744
4c4b4cd2
PH
5745/* Scan STR for a subtype-encoded number, beginning at position K.
5746 Put the position of the character just past the number scanned in
5747 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5748 Return 1 if there was a valid number at the given position, and 0
5749 otherwise. A "subtype-encoded" number consists of the absolute value
5750 in decimal, followed by the letter 'm' to indicate a negative number.
5751 Assumes 0m does not occur. */
14f9c5c9
AS
5752
5753int
d2e4a39e 5754ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
5755{
5756 ULONGEST RU;
5757
d2e4a39e 5758 if (!isdigit (str[k]))
14f9c5c9
AS
5759 return 0;
5760
4c4b4cd2 5761 /* Do it the hard way so as not to make any assumption about
14f9c5c9 5762 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 5763 LONGEST. */
14f9c5c9
AS
5764 RU = 0;
5765 while (isdigit (str[k]))
5766 {
d2e4a39e 5767 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
5768 k += 1;
5769 }
5770
d2e4a39e 5771 if (str[k] == 'm')
14f9c5c9
AS
5772 {
5773 if (R != NULL)
4c4b4cd2 5774 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
5775 k += 1;
5776 }
5777 else if (R != NULL)
5778 *R = (LONGEST) RU;
5779
4c4b4cd2 5780 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
5781 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5782 number representable as a LONGEST (although either would probably work
5783 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 5784 above is always equivalent to the negative of RU. */
14f9c5c9
AS
5785
5786 if (new_k != NULL)
5787 *new_k = k;
5788 return 1;
5789}
5790
4c4b4cd2
PH
5791/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5792 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5793 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 5794
d2e4a39e 5795int
ebf56fd3 5796ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 5797{
d2e4a39e 5798 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
5799 int p;
5800
5801 p = 0;
5802 while (1)
5803 {
d2e4a39e 5804 switch (name[p])
4c4b4cd2
PH
5805 {
5806 case '\0':
5807 return 0;
5808 case 'S':
5809 {
5810 LONGEST W;
5811 if (!ada_scan_number (name, p + 1, &W, &p))
5812 return 0;
5813 if (val == W)
5814 return 1;
5815 break;
5816 }
5817 case 'R':
5818 {
5819 LONGEST L, U;
5820 if (!ada_scan_number (name, p + 1, &L, &p)
5821 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
5822 return 0;
5823 if (val >= L && val <= U)
5824 return 1;
5825 break;
5826 }
5827 case 'O':
5828 return 1;
5829 default:
5830 return 0;
5831 }
5832 }
5833}
5834
5835/* FIXME: Lots of redundancy below. Try to consolidate. */
5836
5837/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5838 ARG_TYPE, extract and return the value of one of its (non-static)
5839 fields. FIELDNO says which field. Differs from value_primitive_field
5840 only in that it can handle packed values of arbitrary type. */
14f9c5c9 5841
4c4b4cd2 5842static struct value *
d2e4a39e 5843ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 5844 struct type *arg_type)
14f9c5c9 5845{
14f9c5c9
AS
5846 struct type *type;
5847
61ee279c 5848 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
5849 type = TYPE_FIELD_TYPE (arg_type, fieldno);
5850
4c4b4cd2 5851 /* Handle packed fields. */
14f9c5c9
AS
5852
5853 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
5854 {
5855 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
5856 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 5857
0fd88904 5858 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
5859 offset + bit_pos / 8,
5860 bit_pos % 8, bit_size, type);
14f9c5c9
AS
5861 }
5862 else
5863 return value_primitive_field (arg1, offset, fieldno, arg_type);
5864}
5865
52ce6436
PH
5866/* Find field with name NAME in object of type TYPE. If found,
5867 set the following for each argument that is non-null:
5868 - *FIELD_TYPE_P to the field's type;
5869 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
5870 an object of that type;
5871 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
5872 - *BIT_SIZE_P to its size in bits if the field is packed, and
5873 0 otherwise;
5874 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
5875 fields up to but not including the desired field, or by the total
5876 number of fields if not found. A NULL value of NAME never
5877 matches; the function just counts visible fields in this case.
5878
5879 Returns 1 if found, 0 otherwise. */
5880
4c4b4cd2 5881static int
76a01679
JB
5882find_struct_field (char *name, struct type *type, int offset,
5883 struct type **field_type_p,
52ce6436
PH
5884 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
5885 int *index_p)
4c4b4cd2
PH
5886{
5887 int i;
5888
61ee279c 5889 type = ada_check_typedef (type);
76a01679 5890
52ce6436
PH
5891 if (field_type_p != NULL)
5892 *field_type_p = NULL;
5893 if (byte_offset_p != NULL)
d5d6fca5 5894 *byte_offset_p = 0;
52ce6436
PH
5895 if (bit_offset_p != NULL)
5896 *bit_offset_p = 0;
5897 if (bit_size_p != NULL)
5898 *bit_size_p = 0;
5899
5900 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
5901 {
5902 int bit_pos = TYPE_FIELD_BITPOS (type, i);
5903 int fld_offset = offset + bit_pos / 8;
5904 char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 5905
4c4b4cd2
PH
5906 if (t_field_name == NULL)
5907 continue;
5908
52ce6436 5909 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
5910 {
5911 int bit_size = TYPE_FIELD_BITSIZE (type, i);
52ce6436
PH
5912 if (field_type_p != NULL)
5913 *field_type_p = TYPE_FIELD_TYPE (type, i);
5914 if (byte_offset_p != NULL)
5915 *byte_offset_p = fld_offset;
5916 if (bit_offset_p != NULL)
5917 *bit_offset_p = bit_pos % 8;
5918 if (bit_size_p != NULL)
5919 *bit_size_p = bit_size;
76a01679
JB
5920 return 1;
5921 }
4c4b4cd2
PH
5922 else if (ada_is_wrapper_field (type, i))
5923 {
52ce6436
PH
5924 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
5925 field_type_p, byte_offset_p, bit_offset_p,
5926 bit_size_p, index_p))
76a01679
JB
5927 return 1;
5928 }
4c4b4cd2
PH
5929 else if (ada_is_variant_part (type, i))
5930 {
52ce6436
PH
5931 /* PNH: Wait. Do we ever execute this section, or is ARG always of
5932 fixed type?? */
4c4b4cd2 5933 int j;
52ce6436
PH
5934 struct type *field_type
5935 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 5936
52ce6436 5937 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 5938 {
76a01679
JB
5939 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
5940 fld_offset
5941 + TYPE_FIELD_BITPOS (field_type, j) / 8,
5942 field_type_p, byte_offset_p,
52ce6436 5943 bit_offset_p, bit_size_p, index_p))
76a01679 5944 return 1;
4c4b4cd2
PH
5945 }
5946 }
52ce6436
PH
5947 else if (index_p != NULL)
5948 *index_p += 1;
4c4b4cd2
PH
5949 }
5950 return 0;
5951}
5952
52ce6436 5953/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 5954
52ce6436
PH
5955static int
5956num_visible_fields (struct type *type)
5957{
5958 int n;
5959 n = 0;
5960 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
5961 return n;
5962}
14f9c5c9 5963
4c4b4cd2 5964/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
5965 and search in it assuming it has (class) type TYPE.
5966 If found, return value, else return NULL.
5967
4c4b4cd2 5968 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 5969
4c4b4cd2 5970static struct value *
d2e4a39e 5971ada_search_struct_field (char *name, struct value *arg, int offset,
4c4b4cd2 5972 struct type *type)
14f9c5c9
AS
5973{
5974 int i;
61ee279c 5975 type = ada_check_typedef (type);
14f9c5c9 5976
52ce6436 5977 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9
AS
5978 {
5979 char *t_field_name = TYPE_FIELD_NAME (type, i);
5980
5981 if (t_field_name == NULL)
4c4b4cd2 5982 continue;
14f9c5c9
AS
5983
5984 else if (field_name_match (t_field_name, name))
4c4b4cd2 5985 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
5986
5987 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 5988 {
06d5cf63
JB
5989 struct value *v = /* Do not let indent join lines here. */
5990 ada_search_struct_field (name, arg,
5991 offset + TYPE_FIELD_BITPOS (type, i) / 8,
5992 TYPE_FIELD_TYPE (type, i));
4c4b4cd2
PH
5993 if (v != NULL)
5994 return v;
5995 }
14f9c5c9
AS
5996
5997 else if (ada_is_variant_part (type, i))
4c4b4cd2 5998 {
52ce6436 5999 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 6000 int j;
61ee279c 6001 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2
PH
6002 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6003
52ce6436 6004 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6005 {
06d5cf63
JB
6006 struct value *v = ada_search_struct_field /* Force line break. */
6007 (name, arg,
6008 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6009 TYPE_FIELD_TYPE (field_type, j));
4c4b4cd2
PH
6010 if (v != NULL)
6011 return v;
6012 }
6013 }
14f9c5c9
AS
6014 }
6015 return NULL;
6016}
d2e4a39e 6017
52ce6436
PH
6018static struct value *ada_index_struct_field_1 (int *, struct value *,
6019 int, struct type *);
6020
6021
6022/* Return field #INDEX in ARG, where the index is that returned by
6023 * find_struct_field through its INDEX_P argument. Adjust the address
6024 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6025 * If found, return value, else return NULL. */
6026
6027static struct value *
6028ada_index_struct_field (int index, struct value *arg, int offset,
6029 struct type *type)
6030{
6031 return ada_index_struct_field_1 (&index, arg, offset, type);
6032}
6033
6034
6035/* Auxiliary function for ada_index_struct_field. Like
6036 * ada_index_struct_field, but takes index from *INDEX_P and modifies
6037 * *INDEX_P. */
6038
6039static struct value *
6040ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6041 struct type *type)
6042{
6043 int i;
6044 type = ada_check_typedef (type);
6045
6046 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6047 {
6048 if (TYPE_FIELD_NAME (type, i) == NULL)
6049 continue;
6050 else if (ada_is_wrapper_field (type, i))
6051 {
6052 struct value *v = /* Do not let indent join lines here. */
6053 ada_index_struct_field_1 (index_p, arg,
6054 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6055 TYPE_FIELD_TYPE (type, i));
6056 if (v != NULL)
6057 return v;
6058 }
6059
6060 else if (ada_is_variant_part (type, i))
6061 {
6062 /* PNH: Do we ever get here? See ada_search_struct_field,
6063 find_struct_field. */
6064 error (_("Cannot assign this kind of variant record"));
6065 }
6066 else if (*index_p == 0)
6067 return ada_value_primitive_field (arg, offset, i, type);
6068 else
6069 *index_p -= 1;
6070 }
6071 return NULL;
6072}
6073
4c4b4cd2
PH
6074/* Given ARG, a value of type (pointer or reference to a)*
6075 structure/union, extract the component named NAME from the ultimate
6076 target structure/union and return it as a value with its
f5938064 6077 appropriate type.
14f9c5c9 6078
4c4b4cd2
PH
6079 The routine searches for NAME among all members of the structure itself
6080 and (recursively) among all members of any wrapper members
14f9c5c9
AS
6081 (e.g., '_parent').
6082
03ee6b2e
PH
6083 If NO_ERR, then simply return NULL in case of error, rather than
6084 calling error. */
14f9c5c9 6085
d2e4a39e 6086struct value *
03ee6b2e 6087ada_value_struct_elt (struct value *arg, char *name, int no_err)
14f9c5c9 6088{
4c4b4cd2 6089 struct type *t, *t1;
d2e4a39e 6090 struct value *v;
14f9c5c9 6091
4c4b4cd2 6092 v = NULL;
df407dfe 6093 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
6094 if (TYPE_CODE (t) == TYPE_CODE_REF)
6095 {
6096 t1 = TYPE_TARGET_TYPE (t);
6097 if (t1 == NULL)
03ee6b2e 6098 goto BadValue;
61ee279c 6099 t1 = ada_check_typedef (t1);
4c4b4cd2 6100 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 6101 {
994b9211 6102 arg = coerce_ref (arg);
76a01679
JB
6103 t = t1;
6104 }
4c4b4cd2 6105 }
14f9c5c9 6106
4c4b4cd2
PH
6107 while (TYPE_CODE (t) == TYPE_CODE_PTR)
6108 {
6109 t1 = TYPE_TARGET_TYPE (t);
6110 if (t1 == NULL)
03ee6b2e 6111 goto BadValue;
61ee279c 6112 t1 = ada_check_typedef (t1);
4c4b4cd2 6113 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
6114 {
6115 arg = value_ind (arg);
6116 t = t1;
6117 }
4c4b4cd2 6118 else
76a01679 6119 break;
4c4b4cd2 6120 }
14f9c5c9 6121
4c4b4cd2 6122 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 6123 goto BadValue;
14f9c5c9 6124
4c4b4cd2
PH
6125 if (t1 == t)
6126 v = ada_search_struct_field (name, arg, 0, t);
6127 else
6128 {
6129 int bit_offset, bit_size, byte_offset;
6130 struct type *field_type;
6131 CORE_ADDR address;
6132
76a01679
JB
6133 if (TYPE_CODE (t) == TYPE_CODE_PTR)
6134 address = value_as_address (arg);
4c4b4cd2 6135 else
0fd88904 6136 address = unpack_pointer (t, value_contents (arg));
14f9c5c9 6137
1ed6ede0 6138 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
76a01679
JB
6139 if (find_struct_field (name, t1, 0,
6140 &field_type, &byte_offset, &bit_offset,
52ce6436 6141 &bit_size, NULL))
76a01679
JB
6142 {
6143 if (bit_size != 0)
6144 {
714e53ab
PH
6145 if (TYPE_CODE (t) == TYPE_CODE_REF)
6146 arg = ada_coerce_ref (arg);
6147 else
6148 arg = ada_value_ind (arg);
76a01679
JB
6149 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
6150 bit_offset, bit_size,
6151 field_type);
6152 }
6153 else
f5938064 6154 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
6155 }
6156 }
6157
03ee6b2e
PH
6158 if (v != NULL || no_err)
6159 return v;
6160 else
323e0a4a 6161 error (_("There is no member named %s."), name);
14f9c5c9 6162
03ee6b2e
PH
6163 BadValue:
6164 if (no_err)
6165 return NULL;
6166 else
6167 error (_("Attempt to extract a component of a value that is not a record."));
14f9c5c9
AS
6168}
6169
6170/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
6171 If DISPP is non-null, add its byte displacement from the beginning of a
6172 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
6173 work for packed fields).
6174
6175 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 6176 followed by "___".
14f9c5c9 6177
4c4b4cd2
PH
6178 TYPE can be either a struct or union. If REFOK, TYPE may also
6179 be a (pointer or reference)+ to a struct or union, and the
6180 ultimate target type will be searched.
14f9c5c9
AS
6181
6182 Looks recursively into variant clauses and parent types.
6183
4c4b4cd2
PH
6184 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6185 TYPE is not a type of the right kind. */
14f9c5c9 6186
4c4b4cd2 6187static struct type *
76a01679
JB
6188ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
6189 int noerr, int *dispp)
14f9c5c9
AS
6190{
6191 int i;
6192
6193 if (name == NULL)
6194 goto BadName;
6195
76a01679 6196 if (refok && type != NULL)
4c4b4cd2
PH
6197 while (1)
6198 {
61ee279c 6199 type = ada_check_typedef (type);
76a01679
JB
6200 if (TYPE_CODE (type) != TYPE_CODE_PTR
6201 && TYPE_CODE (type) != TYPE_CODE_REF)
6202 break;
6203 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 6204 }
14f9c5c9 6205
76a01679 6206 if (type == NULL
1265e4aa
JB
6207 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
6208 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 6209 {
4c4b4cd2 6210 if (noerr)
76a01679 6211 return NULL;
4c4b4cd2 6212 else
76a01679
JB
6213 {
6214 target_terminal_ours ();
6215 gdb_flush (gdb_stdout);
323e0a4a
AC
6216 if (type == NULL)
6217 error (_("Type (null) is not a structure or union type"));
6218 else
6219 {
6220 /* XXX: type_sprint */
6221 fprintf_unfiltered (gdb_stderr, _("Type "));
6222 type_print (type, "", gdb_stderr, -1);
6223 error (_(" is not a structure or union type"));
6224 }
76a01679 6225 }
14f9c5c9
AS
6226 }
6227
6228 type = to_static_fixed_type (type);
6229
6230 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6231 {
6232 char *t_field_name = TYPE_FIELD_NAME (type, i);
6233 struct type *t;
6234 int disp;
d2e4a39e 6235
14f9c5c9 6236 if (t_field_name == NULL)
4c4b4cd2 6237 continue;
14f9c5c9
AS
6238
6239 else if (field_name_match (t_field_name, name))
4c4b4cd2
PH
6240 {
6241 if (dispp != NULL)
6242 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
61ee279c 6243 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 6244 }
14f9c5c9
AS
6245
6246 else if (ada_is_wrapper_field (type, i))
4c4b4cd2
PH
6247 {
6248 disp = 0;
6249 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
6250 0, 1, &disp);
6251 if (t != NULL)
6252 {
6253 if (dispp != NULL)
6254 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6255 return t;
6256 }
6257 }
14f9c5c9
AS
6258
6259 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
6260 {
6261 int j;
61ee279c 6262 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2
PH
6263
6264 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
6265 {
b1f33ddd
JB
6266 /* FIXME pnh 2008/01/26: We check for a field that is
6267 NOT wrapped in a struct, since the compiler sometimes
6268 generates these for unchecked variant types. Revisit
6269 if the compiler changes this practice. */
6270 char *v_field_name = TYPE_FIELD_NAME (field_type, j);
4c4b4cd2 6271 disp = 0;
b1f33ddd
JB
6272 if (v_field_name != NULL
6273 && field_name_match (v_field_name, name))
6274 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
6275 else
6276 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
6277 name, 0, 1, &disp);
6278
4c4b4cd2
PH
6279 if (t != NULL)
6280 {
6281 if (dispp != NULL)
6282 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6283 return t;
6284 }
6285 }
6286 }
14f9c5c9
AS
6287
6288 }
6289
6290BadName:
d2e4a39e 6291 if (!noerr)
14f9c5c9
AS
6292 {
6293 target_terminal_ours ();
6294 gdb_flush (gdb_stdout);
323e0a4a
AC
6295 if (name == NULL)
6296 {
6297 /* XXX: type_sprint */
6298 fprintf_unfiltered (gdb_stderr, _("Type "));
6299 type_print (type, "", gdb_stderr, -1);
6300 error (_(" has no component named <null>"));
6301 }
6302 else
6303 {
6304 /* XXX: type_sprint */
6305 fprintf_unfiltered (gdb_stderr, _("Type "));
6306 type_print (type, "", gdb_stderr, -1);
6307 error (_(" has no component named %s"), name);
6308 }
14f9c5c9
AS
6309 }
6310
6311 return NULL;
6312}
6313
b1f33ddd
JB
6314/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6315 within a value of type OUTER_TYPE, return true iff VAR_TYPE
6316 represents an unchecked union (that is, the variant part of a
6317 record that is named in an Unchecked_Union pragma). */
6318
6319static int
6320is_unchecked_variant (struct type *var_type, struct type *outer_type)
6321{
6322 char *discrim_name = ada_variant_discrim_name (var_type);
6323 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
6324 == NULL);
6325}
6326
6327
14f9c5c9
AS
6328/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6329 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
6330 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6331 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 6332
d2e4a39e 6333int
ebf56fd3 6334ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 6335 const gdb_byte *outer_valaddr)
14f9c5c9
AS
6336{
6337 int others_clause;
6338 int i;
d2e4a39e 6339 char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
6340 struct value *outer;
6341 struct value *discrim;
14f9c5c9
AS
6342 LONGEST discrim_val;
6343
0c281816
JB
6344 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
6345 discrim = ada_value_struct_elt (outer, discrim_name, 1);
6346 if (discrim == NULL)
14f9c5c9 6347 return -1;
0c281816 6348 discrim_val = value_as_long (discrim);
14f9c5c9
AS
6349
6350 others_clause = -1;
6351 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
6352 {
6353 if (ada_is_others_clause (var_type, i))
4c4b4cd2 6354 others_clause = i;
14f9c5c9 6355 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 6356 return i;
14f9c5c9
AS
6357 }
6358
6359 return others_clause;
6360}
d2e4a39e 6361\f
14f9c5c9
AS
6362
6363
4c4b4cd2 6364 /* Dynamic-Sized Records */
14f9c5c9
AS
6365
6366/* Strategy: The type ostensibly attached to a value with dynamic size
6367 (i.e., a size that is not statically recorded in the debugging
6368 data) does not accurately reflect the size or layout of the value.
6369 Our strategy is to convert these values to values with accurate,
4c4b4cd2 6370 conventional types that are constructed on the fly. */
14f9c5c9
AS
6371
6372/* There is a subtle and tricky problem here. In general, we cannot
6373 determine the size of dynamic records without its data. However,
6374 the 'struct value' data structure, which GDB uses to represent
6375 quantities in the inferior process (the target), requires the size
6376 of the type at the time of its allocation in order to reserve space
6377 for GDB's internal copy of the data. That's why the
6378 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 6379 rather than struct value*s.
14f9c5c9
AS
6380
6381 However, GDB's internal history variables ($1, $2, etc.) are
6382 struct value*s containing internal copies of the data that are not, in
6383 general, the same as the data at their corresponding addresses in
6384 the target. Fortunately, the types we give to these values are all
6385 conventional, fixed-size types (as per the strategy described
6386 above), so that we don't usually have to perform the
6387 'to_fixed_xxx_type' conversions to look at their values.
6388 Unfortunately, there is one exception: if one of the internal
6389 history variables is an array whose elements are unconstrained
6390 records, then we will need to create distinct fixed types for each
6391 element selected. */
6392
6393/* The upshot of all of this is that many routines take a (type, host
6394 address, target address) triple as arguments to represent a value.
6395 The host address, if non-null, is supposed to contain an internal
6396 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 6397 target at the target address. */
14f9c5c9
AS
6398
6399/* Assuming that VAL0 represents a pointer value, the result of
6400 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 6401 dynamic-sized types. */
14f9c5c9 6402
d2e4a39e
AS
6403struct value *
6404ada_value_ind (struct value *val0)
14f9c5c9 6405{
d2e4a39e 6406 struct value *val = unwrap_value (value_ind (val0));
4c4b4cd2 6407 return ada_to_fixed_value (val);
14f9c5c9
AS
6408}
6409
6410/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
6411 qualifiers on VAL0. */
6412
d2e4a39e
AS
6413static struct value *
6414ada_coerce_ref (struct value *val0)
6415{
df407dfe 6416 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
6417 {
6418 struct value *val = val0;
994b9211 6419 val = coerce_ref (val);
d2e4a39e 6420 val = unwrap_value (val);
4c4b4cd2 6421 return ada_to_fixed_value (val);
d2e4a39e
AS
6422 }
6423 else
14f9c5c9
AS
6424 return val0;
6425}
6426
6427/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 6428 ALIGNMENT (a power of 2). */
14f9c5c9
AS
6429
6430static unsigned int
ebf56fd3 6431align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
6432{
6433 return (off + alignment - 1) & ~(alignment - 1);
6434}
6435
4c4b4cd2 6436/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
6437
6438static unsigned int
ebf56fd3 6439field_alignment (struct type *type, int f)
14f9c5c9 6440{
d2e4a39e 6441 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 6442 int len;
14f9c5c9
AS
6443 int align_offset;
6444
64a1bf19
JB
6445 /* The field name should never be null, unless the debugging information
6446 is somehow malformed. In this case, we assume the field does not
6447 require any alignment. */
6448 if (name == NULL)
6449 return 1;
6450
6451 len = strlen (name);
6452
4c4b4cd2
PH
6453 if (!isdigit (name[len - 1]))
6454 return 1;
14f9c5c9 6455
d2e4a39e 6456 if (isdigit (name[len - 2]))
14f9c5c9
AS
6457 align_offset = len - 2;
6458 else
6459 align_offset = len - 1;
6460
4c4b4cd2 6461 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
14f9c5c9
AS
6462 return TARGET_CHAR_BIT;
6463
4c4b4cd2
PH
6464 return atoi (name + align_offset) * TARGET_CHAR_BIT;
6465}
6466
6467/* Find a symbol named NAME. Ignores ambiguity. */
6468
6469struct symbol *
6470ada_find_any_symbol (const char *name)
6471{
6472 struct symbol *sym;
6473
6474 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
6475 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
6476 return sym;
6477
6478 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
6479 return sym;
14f9c5c9
AS
6480}
6481
6482/* Find a type named NAME. Ignores ambiguity. */
4c4b4cd2 6483
d2e4a39e 6484struct type *
ebf56fd3 6485ada_find_any_type (const char *name)
14f9c5c9 6486{
4c4b4cd2 6487 struct symbol *sym = ada_find_any_symbol (name);
3c513ee6 6488 struct type *type = NULL;
14f9c5c9 6489
14f9c5c9 6490 if (sym != NULL)
3c513ee6 6491 type = SYMBOL_TYPE (sym);
14f9c5c9 6492
3c513ee6
JB
6493 if (type == NULL)
6494 type = language_lookup_primitive_type_by_name
6495 (language_def (language_ada), current_gdbarch, name);
6496
6497 return type;
14f9c5c9
AS
6498}
6499
aeb5907d
JB
6500/* Given NAME and an associated BLOCK, search all symbols for
6501 NAME suffixed with "___XR", which is the ``renaming'' symbol
4c4b4cd2
PH
6502 associated to NAME. Return this symbol if found, return
6503 NULL otherwise. */
6504
6505struct symbol *
6506ada_find_renaming_symbol (const char *name, struct block *block)
aeb5907d
JB
6507{
6508 struct symbol *sym;
6509
6510 sym = find_old_style_renaming_symbol (name, block);
6511
6512 if (sym != NULL)
6513 return sym;
6514
6515 /* Not right yet. FIXME pnh 7/20/2007. */
6516 sym = ada_find_any_symbol (name);
6517 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
6518 return sym;
6519 else
6520 return NULL;
6521}
6522
6523static struct symbol *
6524find_old_style_renaming_symbol (const char *name, struct block *block)
4c4b4cd2 6525{
7f0df278 6526 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
6527 char *rename;
6528
6529 if (function_sym != NULL)
6530 {
6531 /* If the symbol is defined inside a function, NAME is not fully
6532 qualified. This means we need to prepend the function name
6533 as well as adding the ``___XR'' suffix to build the name of
6534 the associated renaming symbol. */
6535 char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
6536 /* Function names sometimes contain suffixes used
6537 for instance to qualify nested subprograms. When building
6538 the XR type name, we need to make sure that this suffix is
6539 not included. So do not include any suffix in the function
6540 name length below. */
6541 const int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
6542 const int rename_len = function_name_len + 2 /* "__" */
6543 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 6544
529cad9c
PH
6545 /* Strip the suffix if necessary. */
6546 function_name[function_name_len] = '\0';
6547
4c4b4cd2
PH
6548 /* Library-level functions are a special case, as GNAT adds
6549 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 6550 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
6551 have this prefix, so we need to skip this prefix if present. */
6552 if (function_name_len > 5 /* "_ada_" */
6553 && strstr (function_name, "_ada_") == function_name)
6554 function_name = function_name + 5;
6555
6556 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34
PM
6557 xsnprintf (rename, rename_len * sizeof (char), "%s__%s___XR",
6558 function_name, name);
4c4b4cd2
PH
6559 }
6560 else
6561 {
6562 const int rename_len = strlen (name) + 6;
6563 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 6564 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
6565 }
6566
6567 return ada_find_any_symbol (rename);
6568}
6569
14f9c5c9 6570/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 6571 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 6572 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
6573 otherwise return 0. */
6574
14f9c5c9 6575int
d2e4a39e 6576ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
6577{
6578 if (type1 == NULL)
6579 return 1;
6580 else if (type0 == NULL)
6581 return 0;
6582 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
6583 return 1;
6584 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
6585 return 0;
4c4b4cd2
PH
6586 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
6587 return 1;
14f9c5c9
AS
6588 else if (ada_is_packed_array_type (type0))
6589 return 1;
4c4b4cd2
PH
6590 else if (ada_is_array_descriptor_type (type0)
6591 && !ada_is_array_descriptor_type (type1))
14f9c5c9 6592 return 1;
aeb5907d
JB
6593 else
6594 {
6595 const char *type0_name = type_name_no_tag (type0);
6596 const char *type1_name = type_name_no_tag (type1);
6597
6598 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
6599 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
6600 return 1;
6601 }
14f9c5c9
AS
6602 return 0;
6603}
6604
6605/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
6606 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6607
d2e4a39e
AS
6608char *
6609ada_type_name (struct type *type)
14f9c5c9 6610{
d2e4a39e 6611 if (type == NULL)
14f9c5c9
AS
6612 return NULL;
6613 else if (TYPE_NAME (type) != NULL)
6614 return TYPE_NAME (type);
6615 else
6616 return TYPE_TAG_NAME (type);
6617}
6618
6619/* Find a parallel type to TYPE whose name is formed by appending
4c4b4cd2 6620 SUFFIX to the name of TYPE. */
14f9c5c9 6621
d2e4a39e 6622struct type *
ebf56fd3 6623ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 6624{
d2e4a39e 6625 static char *name;
14f9c5c9 6626 static size_t name_len = 0;
14f9c5c9 6627 int len;
d2e4a39e
AS
6628 char *typename = ada_type_name (type);
6629
14f9c5c9
AS
6630 if (typename == NULL)
6631 return NULL;
6632
6633 len = strlen (typename);
6634
d2e4a39e 6635 GROW_VECT (name, name_len, len + strlen (suffix) + 1);
14f9c5c9
AS
6636
6637 strcpy (name, typename);
6638 strcpy (name + len, suffix);
6639
6640 return ada_find_any_type (name);
6641}
6642
6643
6644/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 6645 type describing its fields. Otherwise, return NULL. */
14f9c5c9 6646
d2e4a39e
AS
6647static struct type *
6648dynamic_template_type (struct type *type)
14f9c5c9 6649{
61ee279c 6650 type = ada_check_typedef (type);
14f9c5c9
AS
6651
6652 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 6653 || ada_type_name (type) == NULL)
14f9c5c9 6654 return NULL;
d2e4a39e 6655 else
14f9c5c9
AS
6656 {
6657 int len = strlen (ada_type_name (type));
4c4b4cd2
PH
6658 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
6659 return type;
14f9c5c9 6660 else
4c4b4cd2 6661 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
6662 }
6663}
6664
6665/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 6666 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 6667
d2e4a39e
AS
6668static int
6669is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
6670{
6671 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
d2e4a39e 6672 return name != NULL
14f9c5c9
AS
6673 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
6674 && strstr (name, "___XVL") != NULL;
6675}
6676
4c4b4cd2
PH
6677/* The index of the variant field of TYPE, or -1 if TYPE does not
6678 represent a variant record type. */
14f9c5c9 6679
d2e4a39e 6680static int
4c4b4cd2 6681variant_field_index (struct type *type)
14f9c5c9
AS
6682{
6683 int f;
6684
4c4b4cd2
PH
6685 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6686 return -1;
6687
6688 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
6689 {
6690 if (ada_is_variant_part (type, f))
6691 return f;
6692 }
6693 return -1;
14f9c5c9
AS
6694}
6695
4c4b4cd2
PH
6696/* A record type with no fields. */
6697
d2e4a39e
AS
6698static struct type *
6699empty_record (struct objfile *objfile)
14f9c5c9 6700{
d2e4a39e 6701 struct type *type = alloc_type (objfile);
14f9c5c9
AS
6702 TYPE_CODE (type) = TYPE_CODE_STRUCT;
6703 TYPE_NFIELDS (type) = 0;
6704 TYPE_FIELDS (type) = NULL;
b1f33ddd 6705 INIT_CPLUS_SPECIFIC (type);
14f9c5c9
AS
6706 TYPE_NAME (type) = "<empty>";
6707 TYPE_TAG_NAME (type) = NULL;
14f9c5c9
AS
6708 TYPE_LENGTH (type) = 0;
6709 return type;
6710}
6711
6712/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
6713 the value of type TYPE at VALADDR or ADDRESS (see comments at
6714 the beginning of this section) VAL according to GNAT conventions.
6715 DVAL0 should describe the (portion of a) record that contains any
df407dfe 6716 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
6717 an outer-level type (i.e., as opposed to a branch of a variant.) A
6718 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 6719 of the variant.
14f9c5c9 6720
4c4b4cd2
PH
6721 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6722 length are not statically known are discarded. As a consequence,
6723 VALADDR, ADDRESS and DVAL0 are ignored.
6724
6725 NOTE: Limitations: For now, we assume that dynamic fields and
6726 variants occupy whole numbers of bytes. However, they need not be
6727 byte-aligned. */
6728
6729struct type *
10a2c479 6730ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 6731 const gdb_byte *valaddr,
4c4b4cd2
PH
6732 CORE_ADDR address, struct value *dval0,
6733 int keep_dynamic_fields)
14f9c5c9 6734{
d2e4a39e
AS
6735 struct value *mark = value_mark ();
6736 struct value *dval;
6737 struct type *rtype;
14f9c5c9 6738 int nfields, bit_len;
4c4b4cd2 6739 int variant_field;
14f9c5c9 6740 long off;
4c4b4cd2 6741 int fld_bit_len, bit_incr;
14f9c5c9
AS
6742 int f;
6743
4c4b4cd2
PH
6744 /* Compute the number of fields in this record type that are going
6745 to be processed: unless keep_dynamic_fields, this includes only
6746 fields whose position and length are static will be processed. */
6747 if (keep_dynamic_fields)
6748 nfields = TYPE_NFIELDS (type);
6749 else
6750 {
6751 nfields = 0;
76a01679 6752 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
6753 && !ada_is_variant_part (type, nfields)
6754 && !is_dynamic_field (type, nfields))
6755 nfields++;
6756 }
6757
14f9c5c9
AS
6758 rtype = alloc_type (TYPE_OBJFILE (type));
6759 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6760 INIT_CPLUS_SPECIFIC (rtype);
6761 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 6762 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
6763 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6764 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
6765 TYPE_NAME (rtype) = ada_type_name (type);
6766 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 6767 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 6768
d2e4a39e
AS
6769 off = 0;
6770 bit_len = 0;
4c4b4cd2
PH
6771 variant_field = -1;
6772
14f9c5c9
AS
6773 for (f = 0; f < nfields; f += 1)
6774 {
6c038f32
PH
6775 off = align_value (off, field_alignment (type, f))
6776 + TYPE_FIELD_BITPOS (type, f);
14f9c5c9 6777 TYPE_FIELD_BITPOS (rtype, f) = off;
d2e4a39e 6778 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 6779
d2e4a39e 6780 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
6781 {
6782 variant_field = f;
6783 fld_bit_len = bit_incr = 0;
6784 }
14f9c5c9 6785 else if (is_dynamic_field (type, f))
4c4b4cd2
PH
6786 {
6787 if (dval0 == NULL)
b5304971
JG
6788 {
6789 /* rtype's length is computed based on the run-time
6790 value of discriminants. If the discriminants are not
6791 initialized, the type size may be completely bogus and
6792 GDB may fail to allocate a value for it. So check the
6793 size first before creating the value. */
6794 check_size (rtype);
6795 dval = value_from_contents_and_address (rtype, valaddr, address);
6796 }
4c4b4cd2
PH
6797 else
6798 dval = dval0;
6799
1ed6ede0
JB
6800 /* Get the fixed type of the field. Note that, in this case, we
6801 do not want to get the real type out of the tag: if the current
6802 field is the parent part of a tagged record, we will get the
6803 tag of the object. Clearly wrong: the real type of the parent
6804 is not the real type of the child. We would end up in an infinite
6805 loop. */
4c4b4cd2
PH
6806 TYPE_FIELD_TYPE (rtype, f) =
6807 ada_to_fixed_type
6808 (ada_get_base_type
6809 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f))),
6810 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
1ed6ede0 6811 cond_offset_target (address, off / TARGET_CHAR_BIT), dval, 0);
4c4b4cd2
PH
6812 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6813 bit_incr = fld_bit_len =
6814 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6815 }
14f9c5c9 6816 else
4c4b4cd2
PH
6817 {
6818 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
6819 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6820 if (TYPE_FIELD_BITSIZE (type, f) > 0)
6821 bit_incr = fld_bit_len =
6822 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
6823 else
6824 bit_incr = fld_bit_len =
6825 TYPE_LENGTH (TYPE_FIELD_TYPE (type, f)) * TARGET_CHAR_BIT;
6826 }
14f9c5c9 6827 if (off + fld_bit_len > bit_len)
4c4b4cd2 6828 bit_len = off + fld_bit_len;
14f9c5c9 6829 off += bit_incr;
4c4b4cd2
PH
6830 TYPE_LENGTH (rtype) =
6831 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 6832 }
4c4b4cd2
PH
6833
6834 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 6835 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
6836 the record. This can happen in the presence of representation
6837 clauses. */
6838 if (variant_field >= 0)
6839 {
6840 struct type *branch_type;
6841
6842 off = TYPE_FIELD_BITPOS (rtype, variant_field);
6843
6844 if (dval0 == NULL)
6845 dval = value_from_contents_and_address (rtype, valaddr, address);
6846 else
6847 dval = dval0;
6848
6849 branch_type =
6850 to_fixed_variant_branch_type
6851 (TYPE_FIELD_TYPE (type, variant_field),
6852 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6853 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
6854 if (branch_type == NULL)
6855 {
6856 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
6857 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
6858 TYPE_NFIELDS (rtype) -= 1;
6859 }
6860 else
6861 {
6862 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
6863 TYPE_FIELD_NAME (rtype, variant_field) = "S";
6864 fld_bit_len =
6865 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
6866 TARGET_CHAR_BIT;
6867 if (off + fld_bit_len > bit_len)
6868 bit_len = off + fld_bit_len;
6869 TYPE_LENGTH (rtype) =
6870 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
6871 }
6872 }
6873
714e53ab
PH
6874 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6875 should contain the alignment of that record, which should be a strictly
6876 positive value. If null or negative, then something is wrong, most
6877 probably in the debug info. In that case, we don't round up the size
6878 of the resulting type. If this record is not part of another structure,
6879 the current RTYPE length might be good enough for our purposes. */
6880 if (TYPE_LENGTH (type) <= 0)
6881 {
323e0a4a
AC
6882 if (TYPE_NAME (rtype))
6883 warning (_("Invalid type size for `%s' detected: %d."),
6884 TYPE_NAME (rtype), TYPE_LENGTH (type));
6885 else
6886 warning (_("Invalid type size for <unnamed> detected: %d."),
6887 TYPE_LENGTH (type));
714e53ab
PH
6888 }
6889 else
6890 {
6891 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
6892 TYPE_LENGTH (type));
6893 }
14f9c5c9
AS
6894
6895 value_free_to_mark (mark);
d2e4a39e 6896 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 6897 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
6898 return rtype;
6899}
6900
4c4b4cd2
PH
6901/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6902 of 1. */
14f9c5c9 6903
d2e4a39e 6904static struct type *
fc1a4b47 6905template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
6906 CORE_ADDR address, struct value *dval0)
6907{
6908 return ada_template_to_fixed_record_type_1 (type, valaddr,
6909 address, dval0, 1);
6910}
6911
6912/* An ordinary record type in which ___XVL-convention fields and
6913 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
6914 static approximations, containing all possible fields. Uses
6915 no runtime values. Useless for use in values, but that's OK,
6916 since the results are used only for type determinations. Works on both
6917 structs and unions. Representation note: to save space, we memorize
6918 the result of this function in the TYPE_TARGET_TYPE of the
6919 template type. */
6920
6921static struct type *
6922template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
6923{
6924 struct type *type;
6925 int nfields;
6926 int f;
6927
4c4b4cd2
PH
6928 if (TYPE_TARGET_TYPE (type0) != NULL)
6929 return TYPE_TARGET_TYPE (type0);
6930
6931 nfields = TYPE_NFIELDS (type0);
6932 type = type0;
14f9c5c9
AS
6933
6934 for (f = 0; f < nfields; f += 1)
6935 {
61ee279c 6936 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
4c4b4cd2 6937 struct type *new_type;
14f9c5c9 6938
4c4b4cd2
PH
6939 if (is_dynamic_field (type0, f))
6940 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
14f9c5c9 6941 else
f192137b 6942 new_type = static_unwrap_type (field_type);
4c4b4cd2
PH
6943 if (type == type0 && new_type != field_type)
6944 {
6945 TYPE_TARGET_TYPE (type0) = type = alloc_type (TYPE_OBJFILE (type0));
6946 TYPE_CODE (type) = TYPE_CODE (type0);
6947 INIT_CPLUS_SPECIFIC (type);
6948 TYPE_NFIELDS (type) = nfields;
6949 TYPE_FIELDS (type) = (struct field *)
6950 TYPE_ALLOC (type, nfields * sizeof (struct field));
6951 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
6952 sizeof (struct field) * nfields);
6953 TYPE_NAME (type) = ada_type_name (type0);
6954 TYPE_TAG_NAME (type) = NULL;
876cecd0 6955 TYPE_FIXED_INSTANCE (type) = 1;
4c4b4cd2
PH
6956 TYPE_LENGTH (type) = 0;
6957 }
6958 TYPE_FIELD_TYPE (type, f) = new_type;
6959 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
14f9c5c9 6960 }
14f9c5c9
AS
6961 return type;
6962}
6963
4c4b4cd2 6964/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
6965 whose address in memory is ADDRESS, returns a revision of TYPE,
6966 which should be a non-dynamic-sized record, in which the variant
6967 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
6968 for discriminant values in DVAL0, which can be NULL if the record
6969 contains the necessary discriminant values. */
6970
d2e4a39e 6971static struct type *
fc1a4b47 6972to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 6973 CORE_ADDR address, struct value *dval0)
14f9c5c9 6974{
d2e4a39e 6975 struct value *mark = value_mark ();
4c4b4cd2 6976 struct value *dval;
d2e4a39e 6977 struct type *rtype;
14f9c5c9
AS
6978 struct type *branch_type;
6979 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 6980 int variant_field = variant_field_index (type);
14f9c5c9 6981
4c4b4cd2 6982 if (variant_field == -1)
14f9c5c9
AS
6983 return type;
6984
4c4b4cd2
PH
6985 if (dval0 == NULL)
6986 dval = value_from_contents_and_address (type, valaddr, address);
6987 else
6988 dval = dval0;
6989
14f9c5c9
AS
6990 rtype = alloc_type (TYPE_OBJFILE (type));
6991 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
6992 INIT_CPLUS_SPECIFIC (rtype);
6993 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
6994 TYPE_FIELDS (rtype) =
6995 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6996 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 6997 sizeof (struct field) * nfields);
14f9c5c9
AS
6998 TYPE_NAME (rtype) = ada_type_name (type);
6999 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7000 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
7001 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7002
4c4b4cd2
PH
7003 branch_type = to_fixed_variant_branch_type
7004 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 7005 cond_offset_host (valaddr,
4c4b4cd2
PH
7006 TYPE_FIELD_BITPOS (type, variant_field)
7007 / TARGET_CHAR_BIT),
d2e4a39e 7008 cond_offset_target (address,
4c4b4cd2
PH
7009 TYPE_FIELD_BITPOS (type, variant_field)
7010 / TARGET_CHAR_BIT), dval);
d2e4a39e 7011 if (branch_type == NULL)
14f9c5c9 7012 {
4c4b4cd2
PH
7013 int f;
7014 for (f = variant_field + 1; f < nfields; f += 1)
7015 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 7016 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
7017 }
7018 else
7019 {
4c4b4cd2
PH
7020 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7021 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7022 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 7023 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 7024 }
4c4b4cd2 7025 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 7026
4c4b4cd2 7027 value_free_to_mark (mark);
14f9c5c9
AS
7028 return rtype;
7029}
7030
7031/* An ordinary record type (with fixed-length fields) that describes
7032 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7033 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
7034 should be in DVAL, a record value; it may be NULL if the object
7035 at ADDR itself contains any necessary discriminant values.
7036 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7037 values from the record are needed. Except in the case that DVAL,
7038 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7039 unchecked) is replaced by a particular branch of the variant.
7040
7041 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7042 is questionable and may be removed. It can arise during the
7043 processing of an unconstrained-array-of-record type where all the
7044 variant branches have exactly the same size. This is because in
7045 such cases, the compiler does not bother to use the XVS convention
7046 when encoding the record. I am currently dubious of this
7047 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 7048
d2e4a39e 7049static struct type *
fc1a4b47 7050to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 7051 CORE_ADDR address, struct value *dval)
14f9c5c9 7052{
d2e4a39e 7053 struct type *templ_type;
14f9c5c9 7054
876cecd0 7055 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
7056 return type0;
7057
d2e4a39e 7058 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
7059
7060 if (templ_type != NULL)
7061 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
7062 else if (variant_field_index (type0) >= 0)
7063 {
7064 if (dval == NULL && valaddr == NULL && address == 0)
7065 return type0;
7066 return to_record_with_fixed_variant_part (type0, valaddr, address,
7067 dval);
7068 }
14f9c5c9
AS
7069 else
7070 {
876cecd0 7071 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
7072 return type0;
7073 }
7074
7075}
7076
7077/* An ordinary record type (with fixed-length fields) that describes
7078 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7079 union type. Any necessary discriminants' values should be in DVAL,
7080 a record value. That is, this routine selects the appropriate
7081 branch of the union at ADDR according to the discriminant value
b1f33ddd
JB
7082 indicated in the union's type name. Returns VAR_TYPE0 itself if
7083 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 7084
d2e4a39e 7085static struct type *
fc1a4b47 7086to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 7087 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
7088{
7089 int which;
d2e4a39e
AS
7090 struct type *templ_type;
7091 struct type *var_type;
14f9c5c9
AS
7092
7093 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
7094 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 7095 else
14f9c5c9
AS
7096 var_type = var_type0;
7097
7098 templ_type = ada_find_parallel_type (var_type, "___XVU");
7099
7100 if (templ_type != NULL)
7101 var_type = templ_type;
7102
b1f33ddd
JB
7103 if (is_unchecked_variant (var_type, value_type (dval)))
7104 return var_type0;
d2e4a39e
AS
7105 which =
7106 ada_which_variant_applies (var_type,
0fd88904 7107 value_type (dval), value_contents (dval));
14f9c5c9
AS
7108
7109 if (which < 0)
7110 return empty_record (TYPE_OBJFILE (var_type));
7111 else if (is_dynamic_field (var_type, which))
4c4b4cd2 7112 return to_fixed_record_type
d2e4a39e
AS
7113 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
7114 valaddr, address, dval);
4c4b4cd2 7115 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
7116 return
7117 to_fixed_record_type
7118 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
7119 else
7120 return TYPE_FIELD_TYPE (var_type, which);
7121}
7122
7123/* Assuming that TYPE0 is an array type describing the type of a value
7124 at ADDR, and that DVAL describes a record containing any
7125 discriminants used in TYPE0, returns a type for the value that
7126 contains no dynamic components (that is, no components whose sizes
7127 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7128 true, gives an error message if the resulting type's size is over
4c4b4cd2 7129 varsize_limit. */
14f9c5c9 7130
d2e4a39e
AS
7131static struct type *
7132to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 7133 int ignore_too_big)
14f9c5c9 7134{
d2e4a39e
AS
7135 struct type *index_type_desc;
7136 struct type *result;
14f9c5c9 7137
4c4b4cd2 7138 if (ada_is_packed_array_type (type0) /* revisit? */
876cecd0 7139 || TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 7140 return type0;
14f9c5c9
AS
7141
7142 index_type_desc = ada_find_parallel_type (type0, "___XA");
7143 if (index_type_desc == NULL)
7144 {
61ee279c 7145 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
14f9c5c9 7146 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
7147 depend on the contents of the array in properly constructed
7148 debugging data. */
529cad9c
PH
7149 /* Create a fixed version of the array element type.
7150 We're not providing the address of an element here,
e1d5a0d2 7151 and thus the actual object value cannot be inspected to do
529cad9c
PH
7152 the conversion. This should not be a problem, since arrays of
7153 unconstrained objects are not allowed. In particular, all
7154 the elements of an array of a tagged type should all be of
7155 the same type specified in the debugging info. No need to
7156 consult the object tag. */
1ed6ede0 7157 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9
AS
7158
7159 if (elt_type0 == elt_type)
4c4b4cd2 7160 result = type0;
14f9c5c9 7161 else
4c4b4cd2
PH
7162 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
7163 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
7164 }
7165 else
7166 {
7167 int i;
7168 struct type *elt_type0;
7169
7170 elt_type0 = type0;
7171 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 7172 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
7173
7174 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
7175 depend on the contents of the array in properly constructed
7176 debugging data. */
529cad9c
PH
7177 /* Create a fixed version of the array element type.
7178 We're not providing the address of an element here,
e1d5a0d2 7179 and thus the actual object value cannot be inspected to do
529cad9c
PH
7180 the conversion. This should not be a problem, since arrays of
7181 unconstrained objects are not allowed. In particular, all
7182 the elements of an array of a tagged type should all be of
7183 the same type specified in the debugging info. No need to
7184 consult the object tag. */
1ed6ede0
JB
7185 result =
7186 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
14f9c5c9 7187 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
7188 {
7189 struct type *range_type =
7190 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, i),
7191 dval, TYPE_OBJFILE (type0));
7192 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
7193 result, range_type);
7194 }
d2e4a39e 7195 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 7196 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
7197 }
7198
876cecd0 7199 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 7200 return result;
d2e4a39e 7201}
14f9c5c9
AS
7202
7203
7204/* A standard type (containing no dynamically sized components)
7205 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7206 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 7207 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
7208 ADDRESS or in VALADDR contains these discriminants.
7209
1ed6ede0
JB
7210 If CHECK_TAG is not null, in the case of tagged types, this function
7211 attempts to locate the object's tag and use it to compute the actual
7212 type. However, when ADDRESS is null, we cannot use it to determine the
7213 location of the tag, and therefore compute the tagged type's actual type.
7214 So we return the tagged type without consulting the tag. */
529cad9c 7215
f192137b
JB
7216static struct type *
7217ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 7218 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 7219{
61ee279c 7220 type = ada_check_typedef (type);
d2e4a39e
AS
7221 switch (TYPE_CODE (type))
7222 {
7223 default:
14f9c5c9 7224 return type;
d2e4a39e 7225 case TYPE_CODE_STRUCT:
4c4b4cd2 7226 {
76a01679 7227 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
7228 struct type *fixed_record_type =
7229 to_fixed_record_type (type, valaddr, address, NULL);
529cad9c
PH
7230 /* If STATIC_TYPE is a tagged type and we know the object's address,
7231 then we can determine its tag, and compute the object's actual
1ed6ede0
JB
7232 type from there. Note that we have to use the fixed record
7233 type (the parent part of the record may have dynamic fields
7234 and the way the location of _tag is expressed may depend on
7235 them). */
529cad9c 7236
1ed6ede0 7237 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679
JB
7238 {
7239 struct type *real_type =
1ed6ede0
JB
7240 type_from_tag (value_tag_from_contents_and_address
7241 (fixed_record_type,
7242 valaddr,
7243 address));
76a01679 7244 if (real_type != NULL)
1ed6ede0 7245 return to_fixed_record_type (real_type, valaddr, address, NULL);
76a01679 7246 }
4af88198
JB
7247
7248 /* Check to see if there is a parallel ___XVZ variable.
7249 If there is, then it provides the actual size of our type. */
7250 else if (ada_type_name (fixed_record_type) != NULL)
7251 {
7252 char *name = ada_type_name (fixed_record_type);
7253 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
7254 int xvz_found = 0;
7255 LONGEST size;
7256
88c15c34 7257 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
4af88198
JB
7258 size = get_int_var_value (xvz_name, &xvz_found);
7259 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
7260 {
7261 fixed_record_type = copy_type (fixed_record_type);
7262 TYPE_LENGTH (fixed_record_type) = size;
7263
7264 /* The FIXED_RECORD_TYPE may have be a stub. We have
7265 observed this when the debugging info is STABS, and
7266 apparently it is something that is hard to fix.
7267
7268 In practice, we don't need the actual type definition
7269 at all, because the presence of the XVZ variable allows us
7270 to assume that there must be a XVS type as well, which we
7271 should be able to use later, when we need the actual type
7272 definition.
7273
7274 In the meantime, pretend that the "fixed" type we are
7275 returning is NOT a stub, because this can cause trouble
7276 when using this type to create new types targeting it.
7277 Indeed, the associated creation routines often check
7278 whether the target type is a stub and will try to replace
7279 it, thus using a type with the wrong size. This, in turn,
7280 might cause the new type to have the wrong size too.
7281 Consider the case of an array, for instance, where the size
7282 of the array is computed from the number of elements in
7283 our array multiplied by the size of its element. */
7284 TYPE_STUB (fixed_record_type) = 0;
7285 }
7286 }
1ed6ede0 7287 return fixed_record_type;
4c4b4cd2 7288 }
d2e4a39e 7289 case TYPE_CODE_ARRAY:
4c4b4cd2 7290 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
7291 case TYPE_CODE_UNION:
7292 if (dval == NULL)
4c4b4cd2 7293 return type;
d2e4a39e 7294 else
4c4b4cd2 7295 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 7296 }
14f9c5c9
AS
7297}
7298
f192137b
JB
7299/* The same as ada_to_fixed_type_1, except that it preserves the type
7300 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
7301 ada_to_fixed_type_1 would return the type referenced by TYPE. */
7302
7303struct type *
7304ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
7305 CORE_ADDR address, struct value *dval, int check_tag)
7306
7307{
7308 struct type *fixed_type =
7309 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
7310
7311 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
7312 && TYPE_TARGET_TYPE (type) == fixed_type)
7313 return type;
7314
7315 return fixed_type;
7316}
7317
14f9c5c9 7318/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 7319 TYPE0, but based on no runtime data. */
14f9c5c9 7320
d2e4a39e
AS
7321static struct type *
7322to_static_fixed_type (struct type *type0)
14f9c5c9 7323{
d2e4a39e 7324 struct type *type;
14f9c5c9
AS
7325
7326 if (type0 == NULL)
7327 return NULL;
7328
876cecd0 7329 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
7330 return type0;
7331
61ee279c 7332 type0 = ada_check_typedef (type0);
d2e4a39e 7333
14f9c5c9
AS
7334 switch (TYPE_CODE (type0))
7335 {
7336 default:
7337 return type0;
7338 case TYPE_CODE_STRUCT:
7339 type = dynamic_template_type (type0);
d2e4a39e 7340 if (type != NULL)
4c4b4cd2
PH
7341 return template_to_static_fixed_type (type);
7342 else
7343 return template_to_static_fixed_type (type0);
14f9c5c9
AS
7344 case TYPE_CODE_UNION:
7345 type = ada_find_parallel_type (type0, "___XVU");
7346 if (type != NULL)
4c4b4cd2
PH
7347 return template_to_static_fixed_type (type);
7348 else
7349 return template_to_static_fixed_type (type0);
14f9c5c9
AS
7350 }
7351}
7352
4c4b4cd2
PH
7353/* A static approximation of TYPE with all type wrappers removed. */
7354
d2e4a39e
AS
7355static struct type *
7356static_unwrap_type (struct type *type)
14f9c5c9
AS
7357{
7358 if (ada_is_aligner_type (type))
7359 {
61ee279c 7360 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 7361 if (ada_type_name (type1) == NULL)
4c4b4cd2 7362 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
7363
7364 return static_unwrap_type (type1);
7365 }
d2e4a39e 7366 else
14f9c5c9 7367 {
d2e4a39e
AS
7368 struct type *raw_real_type = ada_get_base_type (type);
7369 if (raw_real_type == type)
4c4b4cd2 7370 return type;
14f9c5c9 7371 else
4c4b4cd2 7372 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
7373 }
7374}
7375
7376/* In some cases, incomplete and private types require
4c4b4cd2 7377 cross-references that are not resolved as records (for example,
14f9c5c9
AS
7378 type Foo;
7379 type FooP is access Foo;
7380 V: FooP;
7381 type Foo is array ...;
4c4b4cd2 7382 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
7383 cross-references to such types, we instead substitute for FooP a
7384 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 7385 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
7386
7387/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
7388 exists, otherwise TYPE. */
7389
d2e4a39e 7390struct type *
61ee279c 7391ada_check_typedef (struct type *type)
14f9c5c9 7392{
727e3d2e
JB
7393 if (type == NULL)
7394 return NULL;
7395
14f9c5c9
AS
7396 CHECK_TYPEDEF (type);
7397 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 7398 || !TYPE_STUB (type)
14f9c5c9
AS
7399 || TYPE_TAG_NAME (type) == NULL)
7400 return type;
d2e4a39e 7401 else
14f9c5c9 7402 {
d2e4a39e
AS
7403 char *name = TYPE_TAG_NAME (type);
7404 struct type *type1 = ada_find_any_type (name);
14f9c5c9
AS
7405 return (type1 == NULL) ? type : type1;
7406 }
7407}
7408
7409/* A value representing the data at VALADDR/ADDRESS as described by
7410 type TYPE0, but with a standard (static-sized) type that correctly
7411 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7412 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 7413 creation of struct values]. */
14f9c5c9 7414
4c4b4cd2
PH
7415static struct value *
7416ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
7417 struct value *val0)
14f9c5c9 7418{
1ed6ede0 7419 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
14f9c5c9
AS
7420 if (type == type0 && val0 != NULL)
7421 return val0;
d2e4a39e 7422 else
4c4b4cd2
PH
7423 return value_from_contents_and_address (type, 0, address);
7424}
7425
7426/* A value representing VAL, but with a standard (static-sized) type
7427 that correctly describes it. Does not necessarily create a new
7428 value. */
7429
7430static struct value *
7431ada_to_fixed_value (struct value *val)
7432{
df407dfe
AC
7433 return ada_to_fixed_value_create (value_type (val),
7434 VALUE_ADDRESS (val) + value_offset (val),
4c4b4cd2 7435 val);
14f9c5c9
AS
7436}
7437
4c4b4cd2 7438/* A value representing VAL, but with a standard (static-sized) type
14f9c5c9
AS
7439 chosen to approximate the real type of VAL as well as possible, but
7440 without consulting any runtime values. For Ada dynamic-sized
4c4b4cd2 7441 types, therefore, the type of the result is likely to be inaccurate. */
14f9c5c9 7442
2c0b251b 7443static struct value *
d2e4a39e 7444ada_to_static_fixed_value (struct value *val)
14f9c5c9 7445{
d2e4a39e 7446 struct type *type =
df407dfe
AC
7447 to_static_fixed_type (static_unwrap_type (value_type (val)));
7448 if (type == value_type (val))
14f9c5c9
AS
7449 return val;
7450 else
4c4b4cd2 7451 return coerce_unspec_val_to_type (val, type);
14f9c5c9 7452}
d2e4a39e 7453\f
14f9c5c9 7454
14f9c5c9
AS
7455/* Attributes */
7456
4c4b4cd2
PH
7457/* Table mapping attribute numbers to names.
7458 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 7459
d2e4a39e 7460static const char *attribute_names[] = {
14f9c5c9
AS
7461 "<?>",
7462
d2e4a39e 7463 "first",
14f9c5c9
AS
7464 "last",
7465 "length",
7466 "image",
14f9c5c9
AS
7467 "max",
7468 "min",
4c4b4cd2
PH
7469 "modulus",
7470 "pos",
7471 "size",
7472 "tag",
14f9c5c9 7473 "val",
14f9c5c9
AS
7474 0
7475};
7476
d2e4a39e 7477const char *
4c4b4cd2 7478ada_attribute_name (enum exp_opcode n)
14f9c5c9 7479{
4c4b4cd2
PH
7480 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
7481 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
7482 else
7483 return attribute_names[0];
7484}
7485
4c4b4cd2 7486/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 7487
4c4b4cd2
PH
7488static LONGEST
7489pos_atr (struct value *arg)
14f9c5c9 7490{
24209737
PH
7491 struct value *val = coerce_ref (arg);
7492 struct type *type = value_type (val);
14f9c5c9 7493
d2e4a39e 7494 if (!discrete_type_p (type))
323e0a4a 7495 error (_("'POS only defined on discrete types"));
14f9c5c9
AS
7496
7497 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7498 {
7499 int i;
24209737 7500 LONGEST v = value_as_long (val);
14f9c5c9 7501
d2e4a39e 7502 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
7503 {
7504 if (v == TYPE_FIELD_BITPOS (type, i))
7505 return i;
7506 }
323e0a4a 7507 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9
AS
7508 }
7509 else
24209737 7510 return value_as_long (val);
4c4b4cd2
PH
7511}
7512
7513static struct value *
3cb382c9 7514value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 7515{
3cb382c9 7516 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
7517}
7518
4c4b4cd2 7519/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 7520
d2e4a39e
AS
7521static struct value *
7522value_val_atr (struct type *type, struct value *arg)
14f9c5c9 7523{
d2e4a39e 7524 if (!discrete_type_p (type))
323e0a4a 7525 error (_("'VAL only defined on discrete types"));
df407dfe 7526 if (!integer_type_p (value_type (arg)))
323e0a4a 7527 error (_("'VAL requires integral argument"));
14f9c5c9
AS
7528
7529 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7530 {
7531 long pos = value_as_long (arg);
7532 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 7533 error (_("argument to 'VAL out of range"));
d2e4a39e 7534 return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
14f9c5c9
AS
7535 }
7536 else
7537 return value_from_longest (type, value_as_long (arg));
7538}
14f9c5c9 7539\f
d2e4a39e 7540
4c4b4cd2 7541 /* Evaluation */
14f9c5c9 7542
4c4b4cd2
PH
7543/* True if TYPE appears to be an Ada character type.
7544 [At the moment, this is true only for Character and Wide_Character;
7545 It is a heuristic test that could stand improvement]. */
14f9c5c9 7546
d2e4a39e
AS
7547int
7548ada_is_character_type (struct type *type)
14f9c5c9 7549{
7b9f71f2
JB
7550 const char *name;
7551
7552 /* If the type code says it's a character, then assume it really is,
7553 and don't check any further. */
7554 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
7555 return 1;
7556
7557 /* Otherwise, assume it's a character type iff it is a discrete type
7558 with a known character type name. */
7559 name = ada_type_name (type);
7560 return (name != NULL
7561 && (TYPE_CODE (type) == TYPE_CODE_INT
7562 || TYPE_CODE (type) == TYPE_CODE_RANGE)
7563 && (strcmp (name, "character") == 0
7564 || strcmp (name, "wide_character") == 0
5a517ebd 7565 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 7566 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
7567}
7568
4c4b4cd2 7569/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
7570
7571int
ebf56fd3 7572ada_is_string_type (struct type *type)
14f9c5c9 7573{
61ee279c 7574 type = ada_check_typedef (type);
d2e4a39e 7575 if (type != NULL
14f9c5c9 7576 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
7577 && (ada_is_simple_array_type (type)
7578 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
7579 && ada_array_arity (type) == 1)
7580 {
7581 struct type *elttype = ada_array_element_type (type, 1);
7582
7583 return ada_is_character_type (elttype);
7584 }
d2e4a39e 7585 else
14f9c5c9
AS
7586 return 0;
7587}
7588
7589
7590/* True if TYPE is a struct type introduced by the compiler to force the
7591 alignment of a value. Such types have a single field with a
4c4b4cd2 7592 distinctive name. */
14f9c5c9
AS
7593
7594int
ebf56fd3 7595ada_is_aligner_type (struct type *type)
14f9c5c9 7596{
61ee279c 7597 type = ada_check_typedef (type);
714e53ab
PH
7598
7599 /* If we can find a parallel XVS type, then the XVS type should
7600 be used instead of this type. And hence, this is not an aligner
7601 type. */
7602 if (ada_find_parallel_type (type, "___XVS") != NULL)
7603 return 0;
7604
14f9c5c9 7605 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
7606 && TYPE_NFIELDS (type) == 1
7607 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
7608}
7609
7610/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 7611 the parallel type. */
14f9c5c9 7612
d2e4a39e
AS
7613struct type *
7614ada_get_base_type (struct type *raw_type)
14f9c5c9 7615{
d2e4a39e
AS
7616 struct type *real_type_namer;
7617 struct type *raw_real_type;
14f9c5c9
AS
7618
7619 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
7620 return raw_type;
7621
7622 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 7623 if (real_type_namer == NULL
14f9c5c9
AS
7624 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
7625 || TYPE_NFIELDS (real_type_namer) != 1)
7626 return raw_type;
7627
7628 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
d2e4a39e 7629 if (raw_real_type == NULL)
14f9c5c9
AS
7630 return raw_type;
7631 else
7632 return raw_real_type;
d2e4a39e 7633}
14f9c5c9 7634
4c4b4cd2 7635/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 7636
d2e4a39e
AS
7637struct type *
7638ada_aligned_type (struct type *type)
14f9c5c9
AS
7639{
7640 if (ada_is_aligner_type (type))
7641 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
7642 else
7643 return ada_get_base_type (type);
7644}
7645
7646
7647/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 7648 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 7649
fc1a4b47
AC
7650const gdb_byte *
7651ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 7652{
d2e4a39e 7653 if (ada_is_aligner_type (type))
14f9c5c9 7654 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
7655 valaddr +
7656 TYPE_FIELD_BITPOS (type,
7657 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
7658 else
7659 return valaddr;
7660}
7661
4c4b4cd2
PH
7662
7663
14f9c5c9 7664/* The printed representation of an enumeration literal with encoded
4c4b4cd2 7665 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
7666const char *
7667ada_enum_name (const char *name)
14f9c5c9 7668{
4c4b4cd2
PH
7669 static char *result;
7670 static size_t result_len = 0;
d2e4a39e 7671 char *tmp;
14f9c5c9 7672
4c4b4cd2
PH
7673 /* First, unqualify the enumeration name:
7674 1. Search for the last '.' character. If we find one, then skip
76a01679
JB
7675 all the preceeding characters, the unqualified name starts
7676 right after that dot.
4c4b4cd2 7677 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
7678 translates dots into "__". Search forward for double underscores,
7679 but stop searching when we hit an overloading suffix, which is
7680 of the form "__" followed by digits. */
4c4b4cd2 7681
c3e5cd34
PH
7682 tmp = strrchr (name, '.');
7683 if (tmp != NULL)
4c4b4cd2
PH
7684 name = tmp + 1;
7685 else
14f9c5c9 7686 {
4c4b4cd2
PH
7687 while ((tmp = strstr (name, "__")) != NULL)
7688 {
7689 if (isdigit (tmp[2]))
7690 break;
7691 else
7692 name = tmp + 2;
7693 }
14f9c5c9
AS
7694 }
7695
7696 if (name[0] == 'Q')
7697 {
14f9c5c9
AS
7698 int v;
7699 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
7700 {
7701 if (sscanf (name + 2, "%x", &v) != 1)
7702 return name;
7703 }
14f9c5c9 7704 else
4c4b4cd2 7705 return name;
14f9c5c9 7706
4c4b4cd2 7707 GROW_VECT (result, result_len, 16);
14f9c5c9 7708 if (isascii (v) && isprint (v))
88c15c34 7709 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 7710 else if (name[1] == 'U')
88c15c34 7711 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 7712 else
88c15c34 7713 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
7714
7715 return result;
7716 }
d2e4a39e 7717 else
4c4b4cd2 7718 {
c3e5cd34
PH
7719 tmp = strstr (name, "__");
7720 if (tmp == NULL)
7721 tmp = strstr (name, "$");
7722 if (tmp != NULL)
4c4b4cd2
PH
7723 {
7724 GROW_VECT (result, result_len, tmp - name + 1);
7725 strncpy (result, name, tmp - name);
7726 result[tmp - name] = '\0';
7727 return result;
7728 }
7729
7730 return name;
7731 }
14f9c5c9
AS
7732}
7733
d2e4a39e 7734static struct value *
ebf56fd3 7735evaluate_subexp (struct type *expect_type, struct expression *exp, int *pos,
4c4b4cd2 7736 enum noside noside)
14f9c5c9 7737{
76a01679 7738 return (*exp->language_defn->la_exp_desc->evaluate_exp)
4c4b4cd2 7739 (expect_type, exp, pos, noside);
14f9c5c9
AS
7740}
7741
7742/* Evaluate the subexpression of EXP starting at *POS as for
7743 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 7744 expression. */
14f9c5c9 7745
d2e4a39e
AS
7746static struct value *
7747evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 7748{
4c4b4cd2 7749 return (*exp->language_defn->la_exp_desc->evaluate_exp)
14f9c5c9
AS
7750 (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
7751}
7752
7753/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 7754 value it wraps. */
14f9c5c9 7755
d2e4a39e
AS
7756static struct value *
7757unwrap_value (struct value *val)
14f9c5c9 7758{
df407dfe 7759 struct type *type = ada_check_typedef (value_type (val));
14f9c5c9
AS
7760 if (ada_is_aligner_type (type))
7761 {
de4d072f 7762 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 7763 struct type *val_type = ada_check_typedef (value_type (v));
14f9c5c9 7764 if (ada_type_name (val_type) == NULL)
4c4b4cd2 7765 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
7766
7767 return unwrap_value (v);
7768 }
d2e4a39e 7769 else
14f9c5c9 7770 {
d2e4a39e 7771 struct type *raw_real_type =
61ee279c 7772 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 7773
14f9c5c9 7774 if (type == raw_real_type)
4c4b4cd2 7775 return val;
14f9c5c9 7776
d2e4a39e 7777 return
4c4b4cd2
PH
7778 coerce_unspec_val_to_type
7779 (val, ada_to_fixed_type (raw_real_type, 0,
df407dfe 7780 VALUE_ADDRESS (val) + value_offset (val),
1ed6ede0 7781 NULL, 1));
14f9c5c9
AS
7782 }
7783}
d2e4a39e
AS
7784
7785static struct value *
7786cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
7787{
7788 LONGEST val;
7789
df407dfe 7790 if (type == value_type (arg))
14f9c5c9 7791 return arg;
df407dfe 7792 else if (ada_is_fixed_point_type (value_type (arg)))
d2e4a39e 7793 val = ada_float_to_fixed (type,
df407dfe 7794 ada_fixed_to_float (value_type (arg),
4c4b4cd2 7795 value_as_long (arg)));
d2e4a39e 7796 else
14f9c5c9 7797 {
a53b7a21 7798 DOUBLEST argd = value_as_double (arg);
14f9c5c9
AS
7799 val = ada_float_to_fixed (type, argd);
7800 }
7801
7802 return value_from_longest (type, val);
7803}
7804
d2e4a39e 7805static struct value *
a53b7a21 7806cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 7807{
df407dfe 7808 DOUBLEST val = ada_fixed_to_float (value_type (arg),
4c4b4cd2 7809 value_as_long (arg));
a53b7a21 7810 return value_from_double (type, val);
14f9c5c9
AS
7811}
7812
4c4b4cd2
PH
7813/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7814 return the converted value. */
7815
d2e4a39e
AS
7816static struct value *
7817coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 7818{
df407dfe 7819 struct type *type2 = value_type (val);
14f9c5c9
AS
7820 if (type == type2)
7821 return val;
7822
61ee279c
PH
7823 type2 = ada_check_typedef (type2);
7824 type = ada_check_typedef (type);
14f9c5c9 7825
d2e4a39e
AS
7826 if (TYPE_CODE (type2) == TYPE_CODE_PTR
7827 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
7828 {
7829 val = ada_value_ind (val);
df407dfe 7830 type2 = value_type (val);
14f9c5c9
AS
7831 }
7832
d2e4a39e 7833 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
7834 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7835 {
7836 if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
4c4b4cd2
PH
7837 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
7838 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
323e0a4a 7839 error (_("Incompatible types in assignment"));
04624583 7840 deprecated_set_value_type (val, type);
14f9c5c9 7841 }
d2e4a39e 7842 return val;
14f9c5c9
AS
7843}
7844
4c4b4cd2
PH
7845static struct value *
7846ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
7847{
7848 struct value *val;
7849 struct type *type1, *type2;
7850 LONGEST v, v1, v2;
7851
994b9211
AC
7852 arg1 = coerce_ref (arg1);
7853 arg2 = coerce_ref (arg2);
df407dfe
AC
7854 type1 = base_type (ada_check_typedef (value_type (arg1)));
7855 type2 = base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 7856
76a01679
JB
7857 if (TYPE_CODE (type1) != TYPE_CODE_INT
7858 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
7859 return value_binop (arg1, arg2, op);
7860
76a01679 7861 switch (op)
4c4b4cd2
PH
7862 {
7863 case BINOP_MOD:
7864 case BINOP_DIV:
7865 case BINOP_REM:
7866 break;
7867 default:
7868 return value_binop (arg1, arg2, op);
7869 }
7870
7871 v2 = value_as_long (arg2);
7872 if (v2 == 0)
323e0a4a 7873 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
7874
7875 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
7876 return value_binop (arg1, arg2, op);
7877
7878 v1 = value_as_long (arg1);
7879 switch (op)
7880 {
7881 case BINOP_DIV:
7882 v = v1 / v2;
76a01679
JB
7883 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
7884 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
7885 break;
7886 case BINOP_REM:
7887 v = v1 % v2;
76a01679
JB
7888 if (v * v1 < 0)
7889 v -= v2;
4c4b4cd2
PH
7890 break;
7891 default:
7892 /* Should not reach this point. */
7893 v = 0;
7894 }
7895
7896 val = allocate_value (type1);
990a07ab 7897 store_unsigned_integer (value_contents_raw (val),
df407dfe 7898 TYPE_LENGTH (value_type (val)), v);
4c4b4cd2
PH
7899 return val;
7900}
7901
7902static int
7903ada_value_equal (struct value *arg1, struct value *arg2)
7904{
df407dfe
AC
7905 if (ada_is_direct_array_type (value_type (arg1))
7906 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 7907 {
f58b38bf
JB
7908 /* Automatically dereference any array reference before
7909 we attempt to perform the comparison. */
7910 arg1 = ada_coerce_ref (arg1);
7911 arg2 = ada_coerce_ref (arg2);
7912
4c4b4cd2
PH
7913 arg1 = ada_coerce_to_simple_array (arg1);
7914 arg2 = ada_coerce_to_simple_array (arg2);
df407dfe
AC
7915 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
7916 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
323e0a4a 7917 error (_("Attempt to compare array with non-array"));
4c4b4cd2 7918 /* FIXME: The following works only for types whose
76a01679
JB
7919 representations use all bits (no padding or undefined bits)
7920 and do not have user-defined equality. */
7921 return
df407dfe 7922 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
0fd88904 7923 && memcmp (value_contents (arg1), value_contents (arg2),
df407dfe 7924 TYPE_LENGTH (value_type (arg1))) == 0;
4c4b4cd2
PH
7925 }
7926 return value_equal (arg1, arg2);
7927}
7928
52ce6436
PH
7929/* Total number of component associations in the aggregate starting at
7930 index PC in EXP. Assumes that index PC is the start of an
7931 OP_AGGREGATE. */
7932
7933static int
7934num_component_specs (struct expression *exp, int pc)
7935{
7936 int n, m, i;
7937 m = exp->elts[pc + 1].longconst;
7938 pc += 3;
7939 n = 0;
7940 for (i = 0; i < m; i += 1)
7941 {
7942 switch (exp->elts[pc].opcode)
7943 {
7944 default:
7945 n += 1;
7946 break;
7947 case OP_CHOICES:
7948 n += exp->elts[pc + 1].longconst;
7949 break;
7950 }
7951 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
7952 }
7953 return n;
7954}
7955
7956/* Assign the result of evaluating EXP starting at *POS to the INDEXth
7957 component of LHS (a simple array or a record), updating *POS past
7958 the expression, assuming that LHS is contained in CONTAINER. Does
7959 not modify the inferior's memory, nor does it modify LHS (unless
7960 LHS == CONTAINER). */
7961
7962static void
7963assign_component (struct value *container, struct value *lhs, LONGEST index,
7964 struct expression *exp, int *pos)
7965{
7966 struct value *mark = value_mark ();
7967 struct value *elt;
7968 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
7969 {
6d84d3d8 7970 struct value *index_val = value_from_longest (builtin_type_int32, index);
52ce6436
PH
7971 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
7972 }
7973 else
7974 {
7975 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
7976 elt = ada_to_fixed_value (unwrap_value (elt));
7977 }
7978
7979 if (exp->elts[*pos].opcode == OP_AGGREGATE)
7980 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
7981 else
7982 value_assign_to_component (container, elt,
7983 ada_evaluate_subexp (NULL, exp, pos,
7984 EVAL_NORMAL));
7985
7986 value_free_to_mark (mark);
7987}
7988
7989/* Assuming that LHS represents an lvalue having a record or array
7990 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
7991 of that aggregate's value to LHS, advancing *POS past the
7992 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
7993 lvalue containing LHS (possibly LHS itself). Does not modify
7994 the inferior's memory, nor does it modify the contents of
7995 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
7996
7997static struct value *
7998assign_aggregate (struct value *container,
7999 struct value *lhs, struct expression *exp,
8000 int *pos, enum noside noside)
8001{
8002 struct type *lhs_type;
8003 int n = exp->elts[*pos+1].longconst;
8004 LONGEST low_index, high_index;
8005 int num_specs;
8006 LONGEST *indices;
8007 int max_indices, num_indices;
8008 int is_array_aggregate;
8009 int i;
8010 struct value *mark = value_mark ();
8011
8012 *pos += 3;
8013 if (noside != EVAL_NORMAL)
8014 {
8015 int i;
8016 for (i = 0; i < n; i += 1)
8017 ada_evaluate_subexp (NULL, exp, pos, noside);
8018 return container;
8019 }
8020
8021 container = ada_coerce_ref (container);
8022 if (ada_is_direct_array_type (value_type (container)))
8023 container = ada_coerce_to_simple_array (container);
8024 lhs = ada_coerce_ref (lhs);
8025 if (!deprecated_value_modifiable (lhs))
8026 error (_("Left operand of assignment is not a modifiable lvalue."));
8027
8028 lhs_type = value_type (lhs);
8029 if (ada_is_direct_array_type (lhs_type))
8030 {
8031 lhs = ada_coerce_to_simple_array (lhs);
8032 lhs_type = value_type (lhs);
8033 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
8034 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
8035 is_array_aggregate = 1;
8036 }
8037 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
8038 {
8039 low_index = 0;
8040 high_index = num_visible_fields (lhs_type) - 1;
8041 is_array_aggregate = 0;
8042 }
8043 else
8044 error (_("Left-hand side must be array or record."));
8045
8046 num_specs = num_component_specs (exp, *pos - 3);
8047 max_indices = 4 * num_specs + 4;
8048 indices = alloca (max_indices * sizeof (indices[0]));
8049 indices[0] = indices[1] = low_index - 1;
8050 indices[2] = indices[3] = high_index + 1;
8051 num_indices = 4;
8052
8053 for (i = 0; i < n; i += 1)
8054 {
8055 switch (exp->elts[*pos].opcode)
8056 {
8057 case OP_CHOICES:
8058 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
8059 &num_indices, max_indices,
8060 low_index, high_index);
8061 break;
8062 case OP_POSITIONAL:
8063 aggregate_assign_positional (container, lhs, exp, pos, indices,
8064 &num_indices, max_indices,
8065 low_index, high_index);
8066 break;
8067 case OP_OTHERS:
8068 if (i != n-1)
8069 error (_("Misplaced 'others' clause"));
8070 aggregate_assign_others (container, lhs, exp, pos, indices,
8071 num_indices, low_index, high_index);
8072 break;
8073 default:
8074 error (_("Internal error: bad aggregate clause"));
8075 }
8076 }
8077
8078 return container;
8079}
8080
8081/* Assign into the component of LHS indexed by the OP_POSITIONAL
8082 construct at *POS, updating *POS past the construct, given that
8083 the positions are relative to lower bound LOW, where HIGH is the
8084 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
8085 updating *NUM_INDICES as needed. CONTAINER is as for
8086 assign_aggregate. */
8087static void
8088aggregate_assign_positional (struct value *container,
8089 struct value *lhs, struct expression *exp,
8090 int *pos, LONGEST *indices, int *num_indices,
8091 int max_indices, LONGEST low, LONGEST high)
8092{
8093 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
8094
8095 if (ind - 1 == high)
e1d5a0d2 8096 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
8097 if (ind <= high)
8098 {
8099 add_component_interval (ind, ind, indices, num_indices, max_indices);
8100 *pos += 3;
8101 assign_component (container, lhs, ind, exp, pos);
8102 }
8103 else
8104 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8105}
8106
8107/* Assign into the components of LHS indexed by the OP_CHOICES
8108 construct at *POS, updating *POS past the construct, given that
8109 the allowable indices are LOW..HIGH. Record the indices assigned
8110 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
8111 needed. CONTAINER is as for assign_aggregate. */
8112static void
8113aggregate_assign_from_choices (struct value *container,
8114 struct value *lhs, struct expression *exp,
8115 int *pos, LONGEST *indices, int *num_indices,
8116 int max_indices, LONGEST low, LONGEST high)
8117{
8118 int j;
8119 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
8120 int choice_pos, expr_pc;
8121 int is_array = ada_is_direct_array_type (value_type (lhs));
8122
8123 choice_pos = *pos += 3;
8124
8125 for (j = 0; j < n_choices; j += 1)
8126 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8127 expr_pc = *pos;
8128 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8129
8130 for (j = 0; j < n_choices; j += 1)
8131 {
8132 LONGEST lower, upper;
8133 enum exp_opcode op = exp->elts[choice_pos].opcode;
8134 if (op == OP_DISCRETE_RANGE)
8135 {
8136 choice_pos += 1;
8137 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8138 EVAL_NORMAL));
8139 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8140 EVAL_NORMAL));
8141 }
8142 else if (is_array)
8143 {
8144 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
8145 EVAL_NORMAL));
8146 upper = lower;
8147 }
8148 else
8149 {
8150 int ind;
8151 char *name;
8152 switch (op)
8153 {
8154 case OP_NAME:
8155 name = &exp->elts[choice_pos + 2].string;
8156 break;
8157 case OP_VAR_VALUE:
8158 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
8159 break;
8160 default:
8161 error (_("Invalid record component association."));
8162 }
8163 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
8164 ind = 0;
8165 if (! find_struct_field (name, value_type (lhs), 0,
8166 NULL, NULL, NULL, NULL, &ind))
8167 error (_("Unknown component name: %s."), name);
8168 lower = upper = ind;
8169 }
8170
8171 if (lower <= upper && (lower < low || upper > high))
8172 error (_("Index in component association out of bounds."));
8173
8174 add_component_interval (lower, upper, indices, num_indices,
8175 max_indices);
8176 while (lower <= upper)
8177 {
8178 int pos1;
8179 pos1 = expr_pc;
8180 assign_component (container, lhs, lower, exp, &pos1);
8181 lower += 1;
8182 }
8183 }
8184}
8185
8186/* Assign the value of the expression in the OP_OTHERS construct in
8187 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8188 have not been previously assigned. The index intervals already assigned
8189 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
8190 OP_OTHERS clause. CONTAINER is as for assign_aggregate*/
8191static void
8192aggregate_assign_others (struct value *container,
8193 struct value *lhs, struct expression *exp,
8194 int *pos, LONGEST *indices, int num_indices,
8195 LONGEST low, LONGEST high)
8196{
8197 int i;
8198 int expr_pc = *pos+1;
8199
8200 for (i = 0; i < num_indices - 2; i += 2)
8201 {
8202 LONGEST ind;
8203 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
8204 {
8205 int pos;
8206 pos = expr_pc;
8207 assign_component (container, lhs, ind, exp, &pos);
8208 }
8209 }
8210 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8211}
8212
8213/* Add the interval [LOW .. HIGH] to the sorted set of intervals
8214 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8215 modifying *SIZE as needed. It is an error if *SIZE exceeds
8216 MAX_SIZE. The resulting intervals do not overlap. */
8217static void
8218add_component_interval (LONGEST low, LONGEST high,
8219 LONGEST* indices, int *size, int max_size)
8220{
8221 int i, j;
8222 for (i = 0; i < *size; i += 2) {
8223 if (high >= indices[i] && low <= indices[i + 1])
8224 {
8225 int kh;
8226 for (kh = i + 2; kh < *size; kh += 2)
8227 if (high < indices[kh])
8228 break;
8229 if (low < indices[i])
8230 indices[i] = low;
8231 indices[i + 1] = indices[kh - 1];
8232 if (high > indices[i + 1])
8233 indices[i + 1] = high;
8234 memcpy (indices + i + 2, indices + kh, *size - kh);
8235 *size -= kh - i - 2;
8236 return;
8237 }
8238 else if (high < indices[i])
8239 break;
8240 }
8241
8242 if (*size == max_size)
8243 error (_("Internal error: miscounted aggregate components."));
8244 *size += 2;
8245 for (j = *size-1; j >= i+2; j -= 1)
8246 indices[j] = indices[j - 2];
8247 indices[i] = low;
8248 indices[i + 1] = high;
8249}
8250
6e48bd2c
JB
8251/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8252 is different. */
8253
8254static struct value *
8255ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
8256{
8257 if (type == ada_check_typedef (value_type (arg2)))
8258 return arg2;
8259
8260 if (ada_is_fixed_point_type (type))
8261 return (cast_to_fixed (type, arg2));
8262
8263 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 8264 return cast_from_fixed (type, arg2);
6e48bd2c
JB
8265
8266 return value_cast (type, arg2);
8267}
8268
52ce6436 8269static struct value *
ebf56fd3 8270ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 8271 int *pos, enum noside noside)
14f9c5c9
AS
8272{
8273 enum exp_opcode op;
14f9c5c9
AS
8274 int tem, tem2, tem3;
8275 int pc;
8276 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
8277 struct type *type;
52ce6436 8278 int nargs, oplen;
d2e4a39e 8279 struct value **argvec;
14f9c5c9 8280
d2e4a39e
AS
8281 pc = *pos;
8282 *pos += 1;
14f9c5c9
AS
8283 op = exp->elts[pc].opcode;
8284
d2e4a39e 8285 switch (op)
14f9c5c9
AS
8286 {
8287 default:
8288 *pos -= 1;
6e48bd2c
JB
8289 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
8290 arg1 = unwrap_value (arg1);
8291
8292 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
8293 then we need to perform the conversion manually, because
8294 evaluate_subexp_standard doesn't do it. This conversion is
8295 necessary in Ada because the different kinds of float/fixed
8296 types in Ada have different representations.
8297
8298 Similarly, we need to perform the conversion from OP_LONG
8299 ourselves. */
8300 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
8301 arg1 = ada_value_cast (expect_type, arg1, noside);
8302
8303 return arg1;
4c4b4cd2
PH
8304
8305 case OP_STRING:
8306 {
76a01679
JB
8307 struct value *result;
8308 *pos -= 1;
8309 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
8310 /* The result type will have code OP_STRING, bashed there from
8311 OP_ARRAY. Bash it back. */
df407dfe
AC
8312 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
8313 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 8314 return result;
4c4b4cd2 8315 }
14f9c5c9
AS
8316
8317 case UNOP_CAST:
8318 (*pos) += 2;
8319 type = exp->elts[pc + 1].type;
8320 arg1 = evaluate_subexp (type, exp, pos, noside);
8321 if (noside == EVAL_SKIP)
4c4b4cd2 8322 goto nosideret;
6e48bd2c 8323 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
8324 return arg1;
8325
4c4b4cd2
PH
8326 case UNOP_QUAL:
8327 (*pos) += 2;
8328 type = exp->elts[pc + 1].type;
8329 return ada_evaluate_subexp (type, exp, pos, noside);
8330
14f9c5c9
AS
8331 case BINOP_ASSIGN:
8332 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
8333 if (exp->elts[*pos].opcode == OP_AGGREGATE)
8334 {
8335 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
8336 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
8337 return arg1;
8338 return ada_value_assign (arg1, arg1);
8339 }
003f3813
JB
8340 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
8341 except if the lhs of our assignment is a convenience variable.
8342 In the case of assigning to a convenience variable, the lhs
8343 should be exactly the result of the evaluation of the rhs. */
8344 type = value_type (arg1);
8345 if (VALUE_LVAL (arg1) == lval_internalvar)
8346 type = NULL;
8347 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 8348 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 8349 return arg1;
df407dfe
AC
8350 if (ada_is_fixed_point_type (value_type (arg1)))
8351 arg2 = cast_to_fixed (value_type (arg1), arg2);
8352 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 8353 error
323e0a4a 8354 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 8355 else
df407dfe 8356 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 8357 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
8358
8359 case BINOP_ADD:
8360 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8361 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8362 if (noside == EVAL_SKIP)
4c4b4cd2 8363 goto nosideret;
2ac8a782
JB
8364 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
8365 return (value_from_longest
8366 (value_type (arg1),
8367 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
8368 if ((ada_is_fixed_point_type (value_type (arg1))
8369 || ada_is_fixed_point_type (value_type (arg2)))
8370 && value_type (arg1) != value_type (arg2))
323e0a4a 8371 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
8372 /* Do the addition, and cast the result to the type of the first
8373 argument. We cannot cast the result to a reference type, so if
8374 ARG1 is a reference type, find its underlying type. */
8375 type = value_type (arg1);
8376 while (TYPE_CODE (type) == TYPE_CODE_REF)
8377 type = TYPE_TARGET_TYPE (type);
f44316fa 8378 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 8379 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
8380
8381 case BINOP_SUB:
8382 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8383 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8384 if (noside == EVAL_SKIP)
4c4b4cd2 8385 goto nosideret;
2ac8a782
JB
8386 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
8387 return (value_from_longest
8388 (value_type (arg1),
8389 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
8390 if ((ada_is_fixed_point_type (value_type (arg1))
8391 || ada_is_fixed_point_type (value_type (arg2)))
8392 && value_type (arg1) != value_type (arg2))
323e0a4a 8393 error (_("Operands of fixed-point subtraction must have the same type"));
b7789565
JB
8394 /* Do the substraction, and cast the result to the type of the first
8395 argument. We cannot cast the result to a reference type, so if
8396 ARG1 is a reference type, find its underlying type. */
8397 type = value_type (arg1);
8398 while (TYPE_CODE (type) == TYPE_CODE_REF)
8399 type = TYPE_TARGET_TYPE (type);
f44316fa 8400 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 8401 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
8402
8403 case BINOP_MUL:
8404 case BINOP_DIV:
e1578042
JB
8405 case BINOP_REM:
8406 case BINOP_MOD:
14f9c5c9
AS
8407 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8408 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8409 if (noside == EVAL_SKIP)
4c4b4cd2 8410 goto nosideret;
e1578042 8411 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
8412 {
8413 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8414 return value_zero (value_type (arg1), not_lval);
8415 }
14f9c5c9 8416 else
4c4b4cd2 8417 {
a53b7a21 8418 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 8419 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 8420 arg1 = cast_from_fixed (type, arg1);
df407dfe 8421 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 8422 arg2 = cast_from_fixed (type, arg2);
f44316fa 8423 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
8424 return ada_value_binop (arg1, arg2, op);
8425 }
8426
4c4b4cd2
PH
8427 case BINOP_EQUAL:
8428 case BINOP_NOTEQUAL:
14f9c5c9 8429 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 8430 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 8431 if (noside == EVAL_SKIP)
76a01679 8432 goto nosideret;
4c4b4cd2 8433 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 8434 tem = 0;
4c4b4cd2 8435 else
f44316fa
UW
8436 {
8437 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8438 tem = ada_value_equal (arg1, arg2);
8439 }
4c4b4cd2 8440 if (op == BINOP_NOTEQUAL)
76a01679 8441 tem = !tem;
fbb06eb1
UW
8442 type = language_bool_type (exp->language_defn, exp->gdbarch);
8443 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
8444
8445 case UNOP_NEG:
8446 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8447 if (noside == EVAL_SKIP)
8448 goto nosideret;
df407dfe
AC
8449 else if (ada_is_fixed_point_type (value_type (arg1)))
8450 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 8451 else
f44316fa
UW
8452 {
8453 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
8454 return value_neg (arg1);
8455 }
4c4b4cd2 8456
2330c6c6
JB
8457 case BINOP_LOGICAL_AND:
8458 case BINOP_LOGICAL_OR:
8459 case UNOP_LOGICAL_NOT:
000d5124
JB
8460 {
8461 struct value *val;
8462
8463 *pos -= 1;
8464 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
8465 type = language_bool_type (exp->language_defn, exp->gdbarch);
8466 return value_cast (type, val);
000d5124 8467 }
2330c6c6
JB
8468
8469 case BINOP_BITWISE_AND:
8470 case BINOP_BITWISE_IOR:
8471 case BINOP_BITWISE_XOR:
000d5124
JB
8472 {
8473 struct value *val;
8474
8475 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
8476 *pos = pc;
8477 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
8478
8479 return value_cast (value_type (arg1), val);
8480 }
2330c6c6 8481
14f9c5c9
AS
8482 case OP_VAR_VALUE:
8483 *pos -= 1;
6799def4 8484
14f9c5c9 8485 if (noside == EVAL_SKIP)
4c4b4cd2
PH
8486 {
8487 *pos += 4;
8488 goto nosideret;
8489 }
8490 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
8491 /* Only encountered when an unresolved symbol occurs in a
8492 context other than a function call, in which case, it is
52ce6436 8493 invalid. */
323e0a4a 8494 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 8495 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
14f9c5c9 8496 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 8497 {
0c1f74cf
JB
8498 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
8499 if (ada_is_tagged_type (type, 0))
8500 {
8501 /* Tagged types are a little special in the fact that the real
8502 type is dynamic and can only be determined by inspecting the
8503 object's tag. This means that we need to get the object's
8504 value first (EVAL_NORMAL) and then extract the actual object
8505 type from its tag.
8506
8507 Note that we cannot skip the final step where we extract
8508 the object type from its tag, because the EVAL_NORMAL phase
8509 results in dynamic components being resolved into fixed ones.
8510 This can cause problems when trying to print the type
8511 description of tagged types whose parent has a dynamic size:
8512 We use the type name of the "_parent" component in order
8513 to print the name of the ancestor type in the type description.
8514 If that component had a dynamic size, the resolution into
8515 a fixed type would result in the loss of that type name,
8516 thus preventing us from printing the name of the ancestor
8517 type in the type description. */
b79819ba
JB
8518 struct type *actual_type;
8519
0c1f74cf 8520 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
b79819ba
JB
8521 actual_type = type_from_tag (ada_value_tag (arg1));
8522 if (actual_type == NULL)
8523 /* If, for some reason, we were unable to determine
8524 the actual type from the tag, then use the static
8525 approximation that we just computed as a fallback.
8526 This can happen if the debugging information is
8527 incomplete, for instance. */
8528 actual_type = type;
8529
8530 return value_zero (actual_type, not_lval);
0c1f74cf
JB
8531 }
8532
4c4b4cd2
PH
8533 *pos += 4;
8534 return value_zero
8535 (to_static_fixed_type
8536 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
8537 not_lval);
8538 }
d2e4a39e 8539 else
4c4b4cd2
PH
8540 {
8541 arg1 =
8542 unwrap_value (evaluate_subexp_standard
8543 (expect_type, exp, pos, noside));
8544 return ada_to_fixed_value (arg1);
8545 }
8546
8547 case OP_FUNCALL:
8548 (*pos) += 2;
8549
8550 /* Allocate arg vector, including space for the function to be
8551 called in argvec[0] and a terminating NULL. */
8552 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8553 argvec =
8554 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
8555
8556 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 8557 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 8558 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
8559 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
8560 else
8561 {
8562 for (tem = 0; tem <= nargs; tem += 1)
8563 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8564 argvec[tem] = 0;
8565
8566 if (noside == EVAL_SKIP)
8567 goto nosideret;
8568 }
8569
df407dfe 8570 if (ada_is_packed_array_type (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 8571 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
df407dfe
AC
8572 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
8573 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
76a01679 8574 && VALUE_LVAL (argvec[0]) == lval_memory))
4c4b4cd2
PH
8575 argvec[0] = value_addr (argvec[0]);
8576
df407dfe 8577 type = ada_check_typedef (value_type (argvec[0]));
4c4b4cd2
PH
8578 if (TYPE_CODE (type) == TYPE_CODE_PTR)
8579 {
61ee279c 8580 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
8581 {
8582 case TYPE_CODE_FUNC:
61ee279c 8583 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
8584 break;
8585 case TYPE_CODE_ARRAY:
8586 break;
8587 case TYPE_CODE_STRUCT:
8588 if (noside != EVAL_AVOID_SIDE_EFFECTS)
8589 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 8590 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
8591 break;
8592 default:
323e0a4a 8593 error (_("cannot subscript or call something of type `%s'"),
df407dfe 8594 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
8595 break;
8596 }
8597 }
8598
8599 switch (TYPE_CODE (type))
8600 {
8601 case TYPE_CODE_FUNC:
8602 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8603 return allocate_value (TYPE_TARGET_TYPE (type));
8604 return call_function_by_hand (argvec[0], nargs, argvec + 1);
8605 case TYPE_CODE_STRUCT:
8606 {
8607 int arity;
8608
4c4b4cd2
PH
8609 arity = ada_array_arity (type);
8610 type = ada_array_element_type (type, nargs);
8611 if (type == NULL)
323e0a4a 8612 error (_("cannot subscript or call a record"));
4c4b4cd2 8613 if (arity != nargs)
323e0a4a 8614 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 8615 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 8616 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
8617 return
8618 unwrap_value (ada_value_subscript
8619 (argvec[0], nargs, argvec + 1));
8620 }
8621 case TYPE_CODE_ARRAY:
8622 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8623 {
8624 type = ada_array_element_type (type, nargs);
8625 if (type == NULL)
323e0a4a 8626 error (_("element type of array unknown"));
4c4b4cd2 8627 else
0a07e705 8628 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
8629 }
8630 return
8631 unwrap_value (ada_value_subscript
8632 (ada_coerce_to_simple_array (argvec[0]),
8633 nargs, argvec + 1));
8634 case TYPE_CODE_PTR: /* Pointer to array */
8635 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
8636 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8637 {
8638 type = ada_array_element_type (type, nargs);
8639 if (type == NULL)
323e0a4a 8640 error (_("element type of array unknown"));
4c4b4cd2 8641 else
0a07e705 8642 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
8643 }
8644 return
8645 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
8646 nargs, argvec + 1));
8647
8648 default:
e1d5a0d2
PH
8649 error (_("Attempt to index or call something other than an "
8650 "array or function"));
4c4b4cd2
PH
8651 }
8652
8653 case TERNOP_SLICE:
8654 {
8655 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8656 struct value *low_bound_val =
8657 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
8658 struct value *high_bound_val =
8659 evaluate_subexp (NULL_TYPE, exp, pos, noside);
8660 LONGEST low_bound;
8661 LONGEST high_bound;
994b9211
AC
8662 low_bound_val = coerce_ref (low_bound_val);
8663 high_bound_val = coerce_ref (high_bound_val);
714e53ab
PH
8664 low_bound = pos_atr (low_bound_val);
8665 high_bound = pos_atr (high_bound_val);
963a6417 8666
4c4b4cd2
PH
8667 if (noside == EVAL_SKIP)
8668 goto nosideret;
8669
4c4b4cd2
PH
8670 /* If this is a reference to an aligner type, then remove all
8671 the aligners. */
df407dfe
AC
8672 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8673 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
8674 TYPE_TARGET_TYPE (value_type (array)) =
8675 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 8676
df407dfe 8677 if (ada_is_packed_array_type (value_type (array)))
323e0a4a 8678 error (_("cannot slice a packed array"));
4c4b4cd2
PH
8679
8680 /* If this is a reference to an array or an array lvalue,
8681 convert to a pointer. */
df407dfe
AC
8682 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8683 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
8684 && VALUE_LVAL (array) == lval_memory))
8685 array = value_addr (array);
8686
1265e4aa 8687 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 8688 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 8689 (value_type (array))))
0b5d8877 8690 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
8691
8692 array = ada_coerce_to_simple_array_ptr (array);
8693
714e53ab
PH
8694 /* If we have more than one level of pointer indirection,
8695 dereference the value until we get only one level. */
df407dfe
AC
8696 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
8697 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
8698 == TYPE_CODE_PTR))
8699 array = value_ind (array);
8700
8701 /* Make sure we really do have an array type before going further,
8702 to avoid a SEGV when trying to get the index type or the target
8703 type later down the road if the debug info generated by
8704 the compiler is incorrect or incomplete. */
df407dfe 8705 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 8706 error (_("cannot take slice of non-array"));
714e53ab 8707
df407dfe 8708 if (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR)
4c4b4cd2 8709 {
0b5d8877 8710 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 8711 return empty_array (TYPE_TARGET_TYPE (value_type (array)),
4c4b4cd2
PH
8712 low_bound);
8713 else
8714 {
8715 struct type *arr_type0 =
df407dfe 8716 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array)),
4c4b4cd2 8717 NULL, 1);
f5938064
JG
8718 return ada_value_slice_from_ptr (array, arr_type0,
8719 longest_to_int (low_bound),
8720 longest_to_int (high_bound));
4c4b4cd2
PH
8721 }
8722 }
8723 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8724 return array;
8725 else if (high_bound < low_bound)
df407dfe 8726 return empty_array (value_type (array), low_bound);
4c4b4cd2 8727 else
529cad9c
PH
8728 return ada_value_slice (array, longest_to_int (low_bound),
8729 longest_to_int (high_bound));
4c4b4cd2 8730 }
14f9c5c9 8731
4c4b4cd2
PH
8732 case UNOP_IN_RANGE:
8733 (*pos) += 2;
8734 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 8735 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 8736
14f9c5c9 8737 if (noside == EVAL_SKIP)
4c4b4cd2 8738 goto nosideret;
14f9c5c9 8739
4c4b4cd2
PH
8740 switch (TYPE_CODE (type))
8741 {
8742 default:
e1d5a0d2
PH
8743 lim_warning (_("Membership test incompletely implemented; "
8744 "always returns true"));
fbb06eb1
UW
8745 type = language_bool_type (exp->language_defn, exp->gdbarch);
8746 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
8747
8748 case TYPE_CODE_RANGE:
030b4912
UW
8749 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
8750 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
8751 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8752 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
8753 type = language_bool_type (exp->language_defn, exp->gdbarch);
8754 return
8755 value_from_longest (type,
4c4b4cd2
PH
8756 (value_less (arg1, arg3)
8757 || value_equal (arg1, arg3))
8758 && (value_less (arg2, arg1)
8759 || value_equal (arg2, arg1)));
8760 }
8761
8762 case BINOP_IN_BOUNDS:
14f9c5c9 8763 (*pos) += 2;
4c4b4cd2
PH
8764 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8765 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 8766
4c4b4cd2
PH
8767 if (noside == EVAL_SKIP)
8768 goto nosideret;
14f9c5c9 8769
4c4b4cd2 8770 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
8771 {
8772 type = language_bool_type (exp->language_defn, exp->gdbarch);
8773 return value_zero (type, not_lval);
8774 }
14f9c5c9 8775
4c4b4cd2 8776 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 8777
df407dfe 8778 if (tem < 1 || tem > ada_array_arity (value_type (arg2)))
323e0a4a 8779 error (_("invalid dimension number to 'range"));
14f9c5c9 8780
4c4b4cd2
PH
8781 arg3 = ada_array_bound (arg2, tem, 1);
8782 arg2 = ada_array_bound (arg2, tem, 0);
d2e4a39e 8783
f44316fa
UW
8784 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8785 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 8786 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 8787 return
fbb06eb1 8788 value_from_longest (type,
4c4b4cd2
PH
8789 (value_less (arg1, arg3)
8790 || value_equal (arg1, arg3))
8791 && (value_less (arg2, arg1)
8792 || value_equal (arg2, arg1)));
8793
8794 case TERNOP_IN_RANGE:
8795 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8796 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8797 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8798
8799 if (noside == EVAL_SKIP)
8800 goto nosideret;
8801
f44316fa
UW
8802 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8803 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 8804 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 8805 return
fbb06eb1 8806 value_from_longest (type,
4c4b4cd2
PH
8807 (value_less (arg1, arg3)
8808 || value_equal (arg1, arg3))
8809 && (value_less (arg2, arg1)
8810 || value_equal (arg2, arg1)));
8811
8812 case OP_ATR_FIRST:
8813 case OP_ATR_LAST:
8814 case OP_ATR_LENGTH:
8815 {
76a01679
JB
8816 struct type *type_arg;
8817 if (exp->elts[*pos].opcode == OP_TYPE)
8818 {
8819 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
8820 arg1 = NULL;
5bc23cb3 8821 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
8822 }
8823 else
8824 {
8825 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8826 type_arg = NULL;
8827 }
8828
8829 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 8830 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
8831 tem = longest_to_int (exp->elts[*pos + 2].longconst);
8832 *pos += 4;
8833
8834 if (noside == EVAL_SKIP)
8835 goto nosideret;
8836
8837 if (type_arg == NULL)
8838 {
8839 arg1 = ada_coerce_ref (arg1);
8840
df407dfe 8841 if (ada_is_packed_array_type (value_type (arg1)))
76a01679
JB
8842 arg1 = ada_coerce_to_simple_array (arg1);
8843
df407dfe 8844 if (tem < 1 || tem > ada_array_arity (value_type (arg1)))
323e0a4a 8845 error (_("invalid dimension number to '%s"),
76a01679
JB
8846 ada_attribute_name (op));
8847
8848 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8849 {
df407dfe 8850 type = ada_index_type (value_type (arg1), tem);
76a01679
JB
8851 if (type == NULL)
8852 error
323e0a4a 8853 (_("attempt to take bound of something that is not an array"));
76a01679
JB
8854 return allocate_value (type);
8855 }
8856
8857 switch (op)
8858 {
8859 default: /* Should never happen. */
323e0a4a 8860 error (_("unexpected attribute encountered"));
76a01679
JB
8861 case OP_ATR_FIRST:
8862 return ada_array_bound (arg1, tem, 0);
8863 case OP_ATR_LAST:
8864 return ada_array_bound (arg1, tem, 1);
8865 case OP_ATR_LENGTH:
8866 return ada_array_length (arg1, tem);
8867 }
8868 }
8869 else if (discrete_type_p (type_arg))
8870 {
8871 struct type *range_type;
8872 char *name = ada_type_name (type_arg);
8873 range_type = NULL;
8874 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
8875 range_type =
8876 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
8877 if (range_type == NULL)
8878 range_type = type_arg;
8879 switch (op)
8880 {
8881 default:
323e0a4a 8882 error (_("unexpected attribute encountered"));
76a01679 8883 case OP_ATR_FIRST:
690cc4eb
PH
8884 return value_from_longest
8885 (range_type, discrete_type_low_bound (range_type));
76a01679 8886 case OP_ATR_LAST:
690cc4eb
PH
8887 return value_from_longest
8888 (range_type, discrete_type_high_bound (range_type));
76a01679 8889 case OP_ATR_LENGTH:
323e0a4a 8890 error (_("the 'length attribute applies only to array types"));
76a01679
JB
8891 }
8892 }
8893 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 8894 error (_("unimplemented type attribute"));
76a01679
JB
8895 else
8896 {
8897 LONGEST low, high;
8898
8899 if (ada_is_packed_array_type (type_arg))
8900 type_arg = decode_packed_array_type (type_arg);
8901
8902 if (tem < 1 || tem > ada_array_arity (type_arg))
323e0a4a 8903 error (_("invalid dimension number to '%s"),
76a01679
JB
8904 ada_attribute_name (op));
8905
8906 type = ada_index_type (type_arg, tem);
8907 if (type == NULL)
8908 error
323e0a4a 8909 (_("attempt to take bound of something that is not an array"));
76a01679
JB
8910 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8911 return allocate_value (type);
8912
8913 switch (op)
8914 {
8915 default:
323e0a4a 8916 error (_("unexpected attribute encountered"));
76a01679
JB
8917 case OP_ATR_FIRST:
8918 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
8919 return value_from_longest (type, low);
8920 case OP_ATR_LAST:
8921 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
8922 return value_from_longest (type, high);
8923 case OP_ATR_LENGTH:
8924 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
8925 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
8926 return value_from_longest (type, high - low + 1);
8927 }
8928 }
14f9c5c9
AS
8929 }
8930
4c4b4cd2
PH
8931 case OP_ATR_TAG:
8932 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8933 if (noside == EVAL_SKIP)
76a01679 8934 goto nosideret;
4c4b4cd2
PH
8935
8936 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 8937 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
8938
8939 return ada_value_tag (arg1);
8940
8941 case OP_ATR_MIN:
8942 case OP_ATR_MAX:
8943 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
8944 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8945 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8946 if (noside == EVAL_SKIP)
76a01679 8947 goto nosideret;
d2e4a39e 8948 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 8949 return value_zero (value_type (arg1), not_lval);
14f9c5c9 8950 else
f44316fa
UW
8951 {
8952 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8953 return value_binop (arg1, arg2,
8954 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
8955 }
14f9c5c9 8956
4c4b4cd2
PH
8957 case OP_ATR_MODULUS:
8958 {
31dedfee 8959 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679 8960 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
4c4b4cd2 8961
76a01679
JB
8962 if (noside == EVAL_SKIP)
8963 goto nosideret;
4c4b4cd2 8964
76a01679 8965 if (!ada_is_modular_type (type_arg))
323e0a4a 8966 error (_("'modulus must be applied to modular type"));
4c4b4cd2 8967
76a01679
JB
8968 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
8969 ada_modulus (type_arg));
4c4b4cd2
PH
8970 }
8971
8972
8973 case OP_ATR_POS:
8974 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
8975 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8976 if (noside == EVAL_SKIP)
76a01679 8977 goto nosideret;
3cb382c9
UW
8978 type = builtin_type (exp->gdbarch)->builtin_int;
8979 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8980 return value_zero (type, not_lval);
14f9c5c9 8981 else
3cb382c9 8982 return value_pos_atr (type, arg1);
14f9c5c9 8983
4c4b4cd2
PH
8984 case OP_ATR_SIZE:
8985 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
8986 type = value_type (arg1);
8987
8988 /* If the argument is a reference, then dereference its type, since
8989 the user is really asking for the size of the actual object,
8990 not the size of the pointer. */
8991 if (TYPE_CODE (type) == TYPE_CODE_REF)
8992 type = TYPE_TARGET_TYPE (type);
8993
4c4b4cd2 8994 if (noside == EVAL_SKIP)
76a01679 8995 goto nosideret;
4c4b4cd2 8996 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
6d2e05aa 8997 return value_zero (builtin_type_int32, not_lval);
4c4b4cd2 8998 else
6d2e05aa 8999 return value_from_longest (builtin_type_int32,
8c1c099f 9000 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
9001
9002 case OP_ATR_VAL:
9003 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 9004 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 9005 type = exp->elts[pc + 2].type;
14f9c5c9 9006 if (noside == EVAL_SKIP)
76a01679 9007 goto nosideret;
4c4b4cd2 9008 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9009 return value_zero (type, not_lval);
4c4b4cd2 9010 else
76a01679 9011 return value_val_atr (type, arg1);
4c4b4cd2
PH
9012
9013 case BINOP_EXP:
9014 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9015 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9016 if (noside == EVAL_SKIP)
9017 goto nosideret;
9018 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 9019 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 9020 else
f44316fa
UW
9021 {
9022 /* For integer exponentiation operations,
9023 only promote the first argument. */
9024 if (is_integral_type (value_type (arg2)))
9025 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9026 else
9027 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9028
9029 return value_binop (arg1, arg2, op);
9030 }
4c4b4cd2
PH
9031
9032 case UNOP_PLUS:
9033 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9034 if (noside == EVAL_SKIP)
9035 goto nosideret;
9036 else
9037 return arg1;
9038
9039 case UNOP_ABS:
9040 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9041 if (noside == EVAL_SKIP)
9042 goto nosideret;
f44316fa 9043 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 9044 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 9045 return value_neg (arg1);
14f9c5c9 9046 else
4c4b4cd2 9047 return arg1;
14f9c5c9
AS
9048
9049 case UNOP_IND:
6b0d7253 9050 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 9051 if (noside == EVAL_SKIP)
4c4b4cd2 9052 goto nosideret;
df407dfe 9053 type = ada_check_typedef (value_type (arg1));
14f9c5c9 9054 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
9055 {
9056 if (ada_is_array_descriptor_type (type))
9057 /* GDB allows dereferencing GNAT array descriptors. */
9058 {
9059 struct type *arrType = ada_type_of_array (arg1, 0);
9060 if (arrType == NULL)
323e0a4a 9061 error (_("Attempt to dereference null array pointer."));
00a4c844 9062 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
9063 }
9064 else if (TYPE_CODE (type) == TYPE_CODE_PTR
9065 || TYPE_CODE (type) == TYPE_CODE_REF
9066 /* In C you can dereference an array to get the 1st elt. */
9067 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab
PH
9068 {
9069 type = to_static_fixed_type
9070 (ada_aligned_type
9071 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
9072 check_size (type);
9073 return value_zero (type, lval_memory);
9074 }
4c4b4cd2 9075 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
9076 {
9077 /* GDB allows dereferencing an int. */
9078 if (expect_type == NULL)
9079 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
9080 lval_memory);
9081 else
9082 {
9083 expect_type =
9084 to_static_fixed_type (ada_aligned_type (expect_type));
9085 return value_zero (expect_type, lval_memory);
9086 }
9087 }
4c4b4cd2 9088 else
323e0a4a 9089 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 9090 }
76a01679 9091 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 9092 type = ada_check_typedef (value_type (arg1));
d2e4a39e 9093
96967637
JB
9094 if (TYPE_CODE (type) == TYPE_CODE_INT)
9095 /* GDB allows dereferencing an int. If we were given
9096 the expect_type, then use that as the target type.
9097 Otherwise, assume that the target type is an int. */
9098 {
9099 if (expect_type != NULL)
9100 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
9101 arg1));
9102 else
9103 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
9104 (CORE_ADDR) value_as_address (arg1));
9105 }
6b0d7253 9106
4c4b4cd2
PH
9107 if (ada_is_array_descriptor_type (type))
9108 /* GDB allows dereferencing GNAT array descriptors. */
9109 return ada_coerce_to_simple_array (arg1);
14f9c5c9 9110 else
4c4b4cd2 9111 return ada_value_ind (arg1);
14f9c5c9
AS
9112
9113 case STRUCTOP_STRUCT:
9114 tem = longest_to_int (exp->elts[pc + 1].longconst);
9115 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
9116 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9117 if (noside == EVAL_SKIP)
4c4b4cd2 9118 goto nosideret;
14f9c5c9 9119 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9120 {
df407dfe 9121 struct type *type1 = value_type (arg1);
76a01679
JB
9122 if (ada_is_tagged_type (type1, 1))
9123 {
9124 type = ada_lookup_struct_elt_type (type1,
9125 &exp->elts[pc + 2].string,
9126 1, 1, NULL);
9127 if (type == NULL)
9128 /* In this case, we assume that the field COULD exist
9129 in some extension of the type. Return an object of
9130 "type" void, which will match any formal
9131 (see ada_type_match). */
9132 return value_zero (builtin_type_void, lval_memory);
9133 }
9134 else
9135 type =
9136 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
9137 0, NULL);
9138
9139 return value_zero (ada_aligned_type (type), lval_memory);
9140 }
14f9c5c9 9141 else
76a01679
JB
9142 return
9143 ada_to_fixed_value (unwrap_value
9144 (ada_value_struct_elt
03ee6b2e 9145 (arg1, &exp->elts[pc + 2].string, 0)));
14f9c5c9 9146 case OP_TYPE:
4c4b4cd2
PH
9147 /* The value is not supposed to be used. This is here to make it
9148 easier to accommodate expressions that contain types. */
14f9c5c9
AS
9149 (*pos) += 2;
9150 if (noside == EVAL_SKIP)
4c4b4cd2 9151 goto nosideret;
14f9c5c9 9152 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 9153 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 9154 else
323e0a4a 9155 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
9156
9157 case OP_AGGREGATE:
9158 case OP_CHOICES:
9159 case OP_OTHERS:
9160 case OP_DISCRETE_RANGE:
9161 case OP_POSITIONAL:
9162 case OP_NAME:
9163 if (noside == EVAL_NORMAL)
9164 switch (op)
9165 {
9166 case OP_NAME:
9167 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 9168 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
9169 case OP_AGGREGATE:
9170 error (_("Aggregates only allowed on the right of an assignment"));
9171 default:
e1d5a0d2 9172 internal_error (__FILE__, __LINE__, _("aggregate apparently mangled"));
52ce6436
PH
9173 }
9174
9175 ada_forward_operator_length (exp, pc, &oplen, &nargs);
9176 *pos += oplen - 1;
9177 for (tem = 0; tem < nargs; tem += 1)
9178 ada_evaluate_subexp (NULL, exp, pos, noside);
9179 goto nosideret;
14f9c5c9
AS
9180 }
9181
9182nosideret:
cb18ec49 9183 return value_from_longest (builtin_type_int8, (LONGEST) 1);
14f9c5c9 9184}
14f9c5c9 9185\f
d2e4a39e 9186
4c4b4cd2 9187 /* Fixed point */
14f9c5c9
AS
9188
9189/* If TYPE encodes an Ada fixed-point type, return the suffix of the
9190 type name that encodes the 'small and 'delta information.
4c4b4cd2 9191 Otherwise, return NULL. */
14f9c5c9 9192
d2e4a39e 9193static const char *
ebf56fd3 9194fixed_type_info (struct type *type)
14f9c5c9 9195{
d2e4a39e 9196 const char *name = ada_type_name (type);
14f9c5c9
AS
9197 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
9198
d2e4a39e
AS
9199 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
9200 {
14f9c5c9
AS
9201 const char *tail = strstr (name, "___XF_");
9202 if (tail == NULL)
4c4b4cd2 9203 return NULL;
d2e4a39e 9204 else
4c4b4cd2 9205 return tail + 5;
14f9c5c9
AS
9206 }
9207 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
9208 return fixed_type_info (TYPE_TARGET_TYPE (type));
9209 else
9210 return NULL;
9211}
9212
4c4b4cd2 9213/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
9214
9215int
ebf56fd3 9216ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
9217{
9218 return fixed_type_info (type) != NULL;
9219}
9220
4c4b4cd2
PH
9221/* Return non-zero iff TYPE represents a System.Address type. */
9222
9223int
9224ada_is_system_address_type (struct type *type)
9225{
9226 return (TYPE_NAME (type)
9227 && strcmp (TYPE_NAME (type), "system__address") == 0);
9228}
9229
14f9c5c9
AS
9230/* Assuming that TYPE is the representation of an Ada fixed-point
9231 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 9232 delta cannot be determined. */
14f9c5c9
AS
9233
9234DOUBLEST
ebf56fd3 9235ada_delta (struct type *type)
14f9c5c9
AS
9236{
9237 const char *encoding = fixed_type_info (type);
facc390f 9238 DOUBLEST num, den;
14f9c5c9 9239
facc390f
JB
9240 /* Strictly speaking, num and den are encoded as integer. However,
9241 they may not fit into a long, and they will have to be converted
9242 to DOUBLEST anyway. So scan them as DOUBLEST. */
9243 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
9244 &num, &den) < 2)
14f9c5c9 9245 return -1.0;
d2e4a39e 9246 else
facc390f 9247 return num / den;
14f9c5c9
AS
9248}
9249
9250/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 9251 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
9252
9253static DOUBLEST
ebf56fd3 9254scaling_factor (struct type *type)
14f9c5c9
AS
9255{
9256 const char *encoding = fixed_type_info (type);
facc390f 9257 DOUBLEST num0, den0, num1, den1;
14f9c5c9 9258 int n;
d2e4a39e 9259
facc390f
JB
9260 /* Strictly speaking, num's and den's are encoded as integer. However,
9261 they may not fit into a long, and they will have to be converted
9262 to DOUBLEST anyway. So scan them as DOUBLEST. */
9263 n = sscanf (encoding,
9264 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
9265 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
9266 &num0, &den0, &num1, &den1);
14f9c5c9
AS
9267
9268 if (n < 2)
9269 return 1.0;
9270 else if (n == 4)
facc390f 9271 return num1 / den1;
d2e4a39e 9272 else
facc390f 9273 return num0 / den0;
14f9c5c9
AS
9274}
9275
9276
9277/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 9278 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
9279
9280DOUBLEST
ebf56fd3 9281ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 9282{
d2e4a39e 9283 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
9284}
9285
4c4b4cd2
PH
9286/* The representation of a fixed-point value of type TYPE
9287 corresponding to the value X. */
14f9c5c9
AS
9288
9289LONGEST
ebf56fd3 9290ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
9291{
9292 return (LONGEST) (x / scaling_factor (type) + 0.5);
9293}
9294
9295
4c4b4cd2 9296 /* VAX floating formats */
14f9c5c9
AS
9297
9298/* Non-zero iff TYPE represents one of the special VAX floating-point
4c4b4cd2
PH
9299 types. */
9300
14f9c5c9 9301int
d2e4a39e 9302ada_is_vax_floating_type (struct type *type)
14f9c5c9 9303{
d2e4a39e 9304 int name_len =
14f9c5c9 9305 (ada_type_name (type) == NULL) ? 0 : strlen (ada_type_name (type));
d2e4a39e 9306 return
14f9c5c9 9307 name_len > 6
d2e4a39e 9308 && (TYPE_CODE (type) == TYPE_CODE_INT
4c4b4cd2
PH
9309 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9310 && strncmp (ada_type_name (type) + name_len - 6, "___XF", 5) == 0;
14f9c5c9
AS
9311}
9312
9313/* The type of special VAX floating-point type this is, assuming
4c4b4cd2
PH
9314 ada_is_vax_floating_point. */
9315
14f9c5c9 9316int
d2e4a39e 9317ada_vax_float_type_suffix (struct type *type)
14f9c5c9 9318{
d2e4a39e 9319 return ada_type_name (type)[strlen (ada_type_name (type)) - 1];
14f9c5c9
AS
9320}
9321
4c4b4cd2 9322/* A value representing the special debugging function that outputs
14f9c5c9 9323 VAX floating-point values of the type represented by TYPE. Assumes
4c4b4cd2
PH
9324 ada_is_vax_floating_type (TYPE). */
9325
d2e4a39e
AS
9326struct value *
9327ada_vax_float_print_function (struct type *type)
9328{
9329 switch (ada_vax_float_type_suffix (type))
9330 {
9331 case 'F':
9332 return get_var_value ("DEBUG_STRING_F", 0);
9333 case 'D':
9334 return get_var_value ("DEBUG_STRING_D", 0);
9335 case 'G':
9336 return get_var_value ("DEBUG_STRING_G", 0);
9337 default:
323e0a4a 9338 error (_("invalid VAX floating-point type"));
d2e4a39e 9339 }
14f9c5c9 9340}
14f9c5c9 9341\f
d2e4a39e 9342
4c4b4cd2 9343 /* Range types */
14f9c5c9
AS
9344
9345/* Scan STR beginning at position K for a discriminant name, and
9346 return the value of that discriminant field of DVAL in *PX. If
9347 PNEW_K is not null, put the position of the character beyond the
9348 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 9349 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
9350
9351static int
07d8f827 9352scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
76a01679 9353 int *pnew_k)
14f9c5c9
AS
9354{
9355 static char *bound_buffer = NULL;
9356 static size_t bound_buffer_len = 0;
9357 char *bound;
9358 char *pend;
d2e4a39e 9359 struct value *bound_val;
14f9c5c9
AS
9360
9361 if (dval == NULL || str == NULL || str[k] == '\0')
9362 return 0;
9363
d2e4a39e 9364 pend = strstr (str + k, "__");
14f9c5c9
AS
9365 if (pend == NULL)
9366 {
d2e4a39e 9367 bound = str + k;
14f9c5c9
AS
9368 k += strlen (bound);
9369 }
d2e4a39e 9370 else
14f9c5c9 9371 {
d2e4a39e 9372 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
14f9c5c9 9373 bound = bound_buffer;
d2e4a39e
AS
9374 strncpy (bound_buffer, str + k, pend - (str + k));
9375 bound[pend - (str + k)] = '\0';
9376 k = pend - str;
14f9c5c9 9377 }
d2e4a39e 9378
df407dfe 9379 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
9380 if (bound_val == NULL)
9381 return 0;
9382
9383 *px = value_as_long (bound_val);
9384 if (pnew_k != NULL)
9385 *pnew_k = k;
9386 return 1;
9387}
9388
9389/* Value of variable named NAME in the current environment. If
9390 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
9391 otherwise causes an error with message ERR_MSG. */
9392
d2e4a39e
AS
9393static struct value *
9394get_var_value (char *name, char *err_msg)
14f9c5c9 9395{
4c4b4cd2 9396 struct ada_symbol_info *syms;
14f9c5c9
AS
9397 int nsyms;
9398
4c4b4cd2
PH
9399 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
9400 &syms);
14f9c5c9
AS
9401
9402 if (nsyms != 1)
9403 {
9404 if (err_msg == NULL)
4c4b4cd2 9405 return 0;
14f9c5c9 9406 else
8a3fe4f8 9407 error (("%s"), err_msg);
14f9c5c9
AS
9408 }
9409
4c4b4cd2 9410 return value_of_variable (syms[0].sym, syms[0].block);
14f9c5c9 9411}
d2e4a39e 9412
14f9c5c9 9413/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
9414 no such variable found, returns 0, and sets *FLAG to 0. If
9415 successful, sets *FLAG to 1. */
9416
14f9c5c9 9417LONGEST
4c4b4cd2 9418get_int_var_value (char *name, int *flag)
14f9c5c9 9419{
4c4b4cd2 9420 struct value *var_val = get_var_value (name, 0);
d2e4a39e 9421
14f9c5c9
AS
9422 if (var_val == 0)
9423 {
9424 if (flag != NULL)
4c4b4cd2 9425 *flag = 0;
14f9c5c9
AS
9426 return 0;
9427 }
9428 else
9429 {
9430 if (flag != NULL)
4c4b4cd2 9431 *flag = 1;
14f9c5c9
AS
9432 return value_as_long (var_val);
9433 }
9434}
d2e4a39e 9435
14f9c5c9
AS
9436
9437/* Return a range type whose base type is that of the range type named
9438 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 9439 from NAME according to the GNAT range encoding conventions.
14f9c5c9
AS
9440 Extract discriminant values, if needed, from DVAL. If a new type
9441 must be created, allocate in OBJFILE's space. The bounds
9442 information, in general, is encoded in NAME, the base type given in
4c4b4cd2 9443 the named range type. */
14f9c5c9 9444
d2e4a39e 9445static struct type *
ebf56fd3 9446to_fixed_range_type (char *name, struct value *dval, struct objfile *objfile)
14f9c5c9
AS
9447{
9448 struct type *raw_type = ada_find_any_type (name);
9449 struct type *base_type;
d2e4a39e 9450 char *subtype_info;
14f9c5c9
AS
9451
9452 if (raw_type == NULL)
6d84d3d8 9453 base_type = builtin_type_int32;
14f9c5c9
AS
9454 else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
9455 base_type = TYPE_TARGET_TYPE (raw_type);
9456 else
9457 base_type = raw_type;
9458
9459 subtype_info = strstr (name, "___XD");
9460 if (subtype_info == NULL)
690cc4eb
PH
9461 {
9462 LONGEST L = discrete_type_low_bound (raw_type);
9463 LONGEST U = discrete_type_high_bound (raw_type);
9464 if (L < INT_MIN || U > INT_MAX)
9465 return raw_type;
9466 else
9467 return create_range_type (alloc_type (objfile), raw_type,
9468 discrete_type_low_bound (raw_type),
9469 discrete_type_high_bound (raw_type));
9470 }
14f9c5c9
AS
9471 else
9472 {
9473 static char *name_buf = NULL;
9474 static size_t name_len = 0;
9475 int prefix_len = subtype_info - name;
9476 LONGEST L, U;
9477 struct type *type;
9478 char *bounds_str;
9479 int n;
9480
9481 GROW_VECT (name_buf, name_len, prefix_len + 5);
9482 strncpy (name_buf, name, prefix_len);
9483 name_buf[prefix_len] = '\0';
9484
9485 subtype_info += 5;
9486 bounds_str = strchr (subtype_info, '_');
9487 n = 1;
9488
d2e4a39e 9489 if (*subtype_info == 'L')
4c4b4cd2
PH
9490 {
9491 if (!ada_scan_number (bounds_str, n, &L, &n)
9492 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
9493 return raw_type;
9494 if (bounds_str[n] == '_')
9495 n += 2;
9496 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
9497 n += 1;
9498 subtype_info += 1;
9499 }
d2e4a39e 9500 else
4c4b4cd2
PH
9501 {
9502 int ok;
9503 strcpy (name_buf + prefix_len, "___L");
9504 L = get_int_var_value (name_buf, &ok);
9505 if (!ok)
9506 {
323e0a4a 9507 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
9508 L = 1;
9509 }
9510 }
14f9c5c9 9511
d2e4a39e 9512 if (*subtype_info == 'U')
4c4b4cd2
PH
9513 {
9514 if (!ada_scan_number (bounds_str, n, &U, &n)
9515 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
9516 return raw_type;
9517 }
d2e4a39e 9518 else
4c4b4cd2
PH
9519 {
9520 int ok;
9521 strcpy (name_buf + prefix_len, "___U");
9522 U = get_int_var_value (name_buf, &ok);
9523 if (!ok)
9524 {
323e0a4a 9525 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
9526 U = L;
9527 }
9528 }
14f9c5c9 9529
d2e4a39e 9530 if (objfile == NULL)
4c4b4cd2 9531 objfile = TYPE_OBJFILE (base_type);
14f9c5c9 9532 type = create_range_type (alloc_type (objfile), base_type, L, U);
d2e4a39e 9533 TYPE_NAME (type) = name;
14f9c5c9
AS
9534 return type;
9535 }
9536}
9537
4c4b4cd2
PH
9538/* True iff NAME is the name of a range type. */
9539
14f9c5c9 9540int
d2e4a39e 9541ada_is_range_type_name (const char *name)
14f9c5c9
AS
9542{
9543 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 9544}
14f9c5c9 9545\f
d2e4a39e 9546
4c4b4cd2
PH
9547 /* Modular types */
9548
9549/* True iff TYPE is an Ada modular type. */
14f9c5c9 9550
14f9c5c9 9551int
d2e4a39e 9552ada_is_modular_type (struct type *type)
14f9c5c9 9553{
4c4b4cd2 9554 struct type *subranged_type = base_type (type);
14f9c5c9
AS
9555
9556 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 9557 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 9558 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
9559}
9560
0056e4d5
JB
9561/* Try to determine the lower and upper bounds of the given modular type
9562 using the type name only. Return non-zero and set L and U as the lower
9563 and upper bounds (respectively) if successful. */
9564
9565int
9566ada_modulus_from_name (struct type *type, ULONGEST *modulus)
9567{
9568 char *name = ada_type_name (type);
9569 char *suffix;
9570 int k;
9571 LONGEST U;
9572
9573 if (name == NULL)
9574 return 0;
9575
9576 /* Discrete type bounds are encoded using an __XD suffix. In our case,
9577 we are looking for static bounds, which means an __XDLU suffix.
9578 Moreover, we know that the lower bound of modular types is always
9579 zero, so the actual suffix should start with "__XDLU_0__", and
9580 then be followed by the upper bound value. */
9581 suffix = strstr (name, "__XDLU_0__");
9582 if (suffix == NULL)
9583 return 0;
9584 k = 10;
9585 if (!ada_scan_number (suffix, k, &U, NULL))
9586 return 0;
9587
9588 *modulus = (ULONGEST) U + 1;
9589 return 1;
9590}
9591
4c4b4cd2
PH
9592/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9593
61ee279c 9594ULONGEST
0056e4d5 9595ada_modulus (struct type *type)
14f9c5c9 9596{
0056e4d5
JB
9597 ULONGEST modulus;
9598
9599 /* Normally, the modulus of a modular type is equal to the value of
9600 its upper bound + 1. However, the upper bound is currently stored
9601 as an int, which is not always big enough to hold the actual bound
9602 value. To workaround this, try to take advantage of the encoding
9603 that GNAT uses with with discrete types. To avoid some unnecessary
9604 parsing, we do this only when the size of TYPE is greater than
9605 the size of the field holding the bound. */
9606 if (TYPE_LENGTH (type) > sizeof (TYPE_HIGH_BOUND (type))
9607 && ada_modulus_from_name (type, &modulus))
9608 return modulus;
9609
d37209fd 9610 return (ULONGEST) (unsigned int) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 9611}
d2e4a39e 9612\f
f7f9143b
JB
9613
9614/* Ada exception catchpoint support:
9615 ---------------------------------
9616
9617 We support 3 kinds of exception catchpoints:
9618 . catchpoints on Ada exceptions
9619 . catchpoints on unhandled Ada exceptions
9620 . catchpoints on failed assertions
9621
9622 Exceptions raised during failed assertions, or unhandled exceptions
9623 could perfectly be caught with the general catchpoint on Ada exceptions.
9624 However, we can easily differentiate these two special cases, and having
9625 the option to distinguish these two cases from the rest can be useful
9626 to zero-in on certain situations.
9627
9628 Exception catchpoints are a specialized form of breakpoint,
9629 since they rely on inserting breakpoints inside known routines
9630 of the GNAT runtime. The implementation therefore uses a standard
9631 breakpoint structure of the BP_BREAKPOINT type, but with its own set
9632 of breakpoint_ops.
9633
0259addd
JB
9634 Support in the runtime for exception catchpoints have been changed
9635 a few times already, and these changes affect the implementation
9636 of these catchpoints. In order to be able to support several
9637 variants of the runtime, we use a sniffer that will determine
9638 the runtime variant used by the program being debugged.
9639
f7f9143b
JB
9640 At this time, we do not support the use of conditions on Ada exception
9641 catchpoints. The COND and COND_STRING fields are therefore set
9642 to NULL (most of the time, see below).
9643
9644 Conditions where EXP_STRING, COND, and COND_STRING are used:
9645
9646 When a user specifies the name of a specific exception in the case
9647 of catchpoints on Ada exceptions, we store the name of that exception
9648 in the EXP_STRING. We then translate this request into an actual
9649 condition stored in COND_STRING, and then parse it into an expression
9650 stored in COND. */
9651
9652/* The different types of catchpoints that we introduced for catching
9653 Ada exceptions. */
9654
9655enum exception_catchpoint_kind
9656{
9657 ex_catch_exception,
9658 ex_catch_exception_unhandled,
9659 ex_catch_assert
9660};
9661
3d0b0fa3
JB
9662/* Ada's standard exceptions. */
9663
9664static char *standard_exc[] = {
9665 "constraint_error",
9666 "program_error",
9667 "storage_error",
9668 "tasking_error"
9669};
9670
0259addd
JB
9671typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
9672
9673/* A structure that describes how to support exception catchpoints
9674 for a given executable. */
9675
9676struct exception_support_info
9677{
9678 /* The name of the symbol to break on in order to insert
9679 a catchpoint on exceptions. */
9680 const char *catch_exception_sym;
9681
9682 /* The name of the symbol to break on in order to insert
9683 a catchpoint on unhandled exceptions. */
9684 const char *catch_exception_unhandled_sym;
9685
9686 /* The name of the symbol to break on in order to insert
9687 a catchpoint on failed assertions. */
9688 const char *catch_assert_sym;
9689
9690 /* Assuming that the inferior just triggered an unhandled exception
9691 catchpoint, this function is responsible for returning the address
9692 in inferior memory where the name of that exception is stored.
9693 Return zero if the address could not be computed. */
9694 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
9695};
9696
9697static CORE_ADDR ada_unhandled_exception_name_addr (void);
9698static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
9699
9700/* The following exception support info structure describes how to
9701 implement exception catchpoints with the latest version of the
9702 Ada runtime (as of 2007-03-06). */
9703
9704static const struct exception_support_info default_exception_support_info =
9705{
9706 "__gnat_debug_raise_exception", /* catch_exception_sym */
9707 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9708 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9709 ada_unhandled_exception_name_addr
9710};
9711
9712/* The following exception support info structure describes how to
9713 implement exception catchpoints with a slightly older version
9714 of the Ada runtime. */
9715
9716static const struct exception_support_info exception_support_info_fallback =
9717{
9718 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
9719 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9720 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9721 ada_unhandled_exception_name_addr_from_raise
9722};
9723
9724/* For each executable, we sniff which exception info structure to use
9725 and cache it in the following global variable. */
9726
9727static const struct exception_support_info *exception_info = NULL;
9728
9729/* Inspect the Ada runtime and determine which exception info structure
9730 should be used to provide support for exception catchpoints.
9731
9732 This function will always set exception_info, or raise an error. */
9733
9734static void
9735ada_exception_support_info_sniffer (void)
9736{
9737 struct symbol *sym;
9738
9739 /* If the exception info is already known, then no need to recompute it. */
9740 if (exception_info != NULL)
9741 return;
9742
9743 /* Check the latest (default) exception support info. */
9744 sym = standard_lookup (default_exception_support_info.catch_exception_sym,
9745 NULL, VAR_DOMAIN);
9746 if (sym != NULL)
9747 {
9748 exception_info = &default_exception_support_info;
9749 return;
9750 }
9751
9752 /* Try our fallback exception suport info. */
9753 sym = standard_lookup (exception_support_info_fallback.catch_exception_sym,
9754 NULL, VAR_DOMAIN);
9755 if (sym != NULL)
9756 {
9757 exception_info = &exception_support_info_fallback;
9758 return;
9759 }
9760
9761 /* Sometimes, it is normal for us to not be able to find the routine
9762 we are looking for. This happens when the program is linked with
9763 the shared version of the GNAT runtime, and the program has not been
9764 started yet. Inform the user of these two possible causes if
9765 applicable. */
9766
9767 if (ada_update_initial_language (language_unknown, NULL) != language_ada)
9768 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
9769
9770 /* If the symbol does not exist, then check that the program is
9771 already started, to make sure that shared libraries have been
9772 loaded. If it is not started, this may mean that the symbol is
9773 in a shared library. */
9774
9775 if (ptid_get_pid (inferior_ptid) == 0)
9776 error (_("Unable to insert catchpoint. Try to start the program first."));
9777
9778 /* At this point, we know that we are debugging an Ada program and
9779 that the inferior has been started, but we still are not able to
9780 find the run-time symbols. That can mean that we are in
9781 configurable run time mode, or that a-except as been optimized
9782 out by the linker... In any case, at this point it is not worth
9783 supporting this feature. */
9784
9785 error (_("Cannot insert catchpoints in this configuration."));
9786}
9787
9788/* An observer of "executable_changed" events.
9789 Its role is to clear certain cached values that need to be recomputed
9790 each time a new executable is loaded by GDB. */
9791
9792static void
781b42b0 9793ada_executable_changed_observer (void)
0259addd
JB
9794{
9795 /* If the executable changed, then it is possible that the Ada runtime
9796 is different. So we need to invalidate the exception support info
9797 cache. */
9798 exception_info = NULL;
9799}
9800
f7f9143b
JB
9801/* Return the name of the function at PC, NULL if could not find it.
9802 This function only checks the debugging information, not the symbol
9803 table. */
9804
9805static char *
9806function_name_from_pc (CORE_ADDR pc)
9807{
9808 char *func_name;
9809
9810 if (!find_pc_partial_function (pc, &func_name, NULL, NULL))
9811 return NULL;
9812
9813 return func_name;
9814}
9815
9816/* True iff FRAME is very likely to be that of a function that is
9817 part of the runtime system. This is all very heuristic, but is
9818 intended to be used as advice as to what frames are uninteresting
9819 to most users. */
9820
9821static int
9822is_known_support_routine (struct frame_info *frame)
9823{
4ed6b5be 9824 struct symtab_and_line sal;
f7f9143b
JB
9825 char *func_name;
9826 int i;
f7f9143b 9827
4ed6b5be
JB
9828 /* If this code does not have any debugging information (no symtab),
9829 This cannot be any user code. */
f7f9143b 9830
4ed6b5be 9831 find_frame_sal (frame, &sal);
f7f9143b
JB
9832 if (sal.symtab == NULL)
9833 return 1;
9834
4ed6b5be
JB
9835 /* If there is a symtab, but the associated source file cannot be
9836 located, then assume this is not user code: Selecting a frame
9837 for which we cannot display the code would not be very helpful
9838 for the user. This should also take care of case such as VxWorks
9839 where the kernel has some debugging info provided for a few units. */
f7f9143b 9840
9bbc9174 9841 if (symtab_to_fullname (sal.symtab) == NULL)
f7f9143b
JB
9842 return 1;
9843
4ed6b5be
JB
9844 /* Check the unit filename againt the Ada runtime file naming.
9845 We also check the name of the objfile against the name of some
9846 known system libraries that sometimes come with debugging info
9847 too. */
9848
f7f9143b
JB
9849 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
9850 {
9851 re_comp (known_runtime_file_name_patterns[i]);
9852 if (re_exec (sal.symtab->filename))
9853 return 1;
4ed6b5be
JB
9854 if (sal.symtab->objfile != NULL
9855 && re_exec (sal.symtab->objfile->name))
9856 return 1;
f7f9143b
JB
9857 }
9858
4ed6b5be 9859 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 9860
4ed6b5be 9861 func_name = function_name_from_pc (get_frame_address_in_block (frame));
f7f9143b
JB
9862 if (func_name == NULL)
9863 return 1;
9864
9865 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
9866 {
9867 re_comp (known_auxiliary_function_name_patterns[i]);
9868 if (re_exec (func_name))
9869 return 1;
9870 }
9871
9872 return 0;
9873}
9874
9875/* Find the first frame that contains debugging information and that is not
9876 part of the Ada run-time, starting from FI and moving upward. */
9877
0ef643c8 9878void
f7f9143b
JB
9879ada_find_printable_frame (struct frame_info *fi)
9880{
9881 for (; fi != NULL; fi = get_prev_frame (fi))
9882 {
9883 if (!is_known_support_routine (fi))
9884 {
9885 select_frame (fi);
9886 break;
9887 }
9888 }
9889
9890}
9891
9892/* Assuming that the inferior just triggered an unhandled exception
9893 catchpoint, return the address in inferior memory where the name
9894 of the exception is stored.
9895
9896 Return zero if the address could not be computed. */
9897
9898static CORE_ADDR
9899ada_unhandled_exception_name_addr (void)
0259addd
JB
9900{
9901 return parse_and_eval_address ("e.full_name");
9902}
9903
9904/* Same as ada_unhandled_exception_name_addr, except that this function
9905 should be used when the inferior uses an older version of the runtime,
9906 where the exception name needs to be extracted from a specific frame
9907 several frames up in the callstack. */
9908
9909static CORE_ADDR
9910ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
9911{
9912 int frame_level;
9913 struct frame_info *fi;
9914
9915 /* To determine the name of this exception, we need to select
9916 the frame corresponding to RAISE_SYM_NAME. This frame is
9917 at least 3 levels up, so we simply skip the first 3 frames
9918 without checking the name of their associated function. */
9919 fi = get_current_frame ();
9920 for (frame_level = 0; frame_level < 3; frame_level += 1)
9921 if (fi != NULL)
9922 fi = get_prev_frame (fi);
9923
9924 while (fi != NULL)
9925 {
9926 const char *func_name =
9927 function_name_from_pc (get_frame_address_in_block (fi));
9928 if (func_name != NULL
0259addd 9929 && strcmp (func_name, exception_info->catch_exception_sym) == 0)
f7f9143b
JB
9930 break; /* We found the frame we were looking for... */
9931 fi = get_prev_frame (fi);
9932 }
9933
9934 if (fi == NULL)
9935 return 0;
9936
9937 select_frame (fi);
9938 return parse_and_eval_address ("id.full_name");
9939}
9940
9941/* Assuming the inferior just triggered an Ada exception catchpoint
9942 (of any type), return the address in inferior memory where the name
9943 of the exception is stored, if applicable.
9944
9945 Return zero if the address could not be computed, or if not relevant. */
9946
9947static CORE_ADDR
9948ada_exception_name_addr_1 (enum exception_catchpoint_kind ex,
9949 struct breakpoint *b)
9950{
9951 switch (ex)
9952 {
9953 case ex_catch_exception:
9954 return (parse_and_eval_address ("e.full_name"));
9955 break;
9956
9957 case ex_catch_exception_unhandled:
0259addd 9958 return exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
9959 break;
9960
9961 case ex_catch_assert:
9962 return 0; /* Exception name is not relevant in this case. */
9963 break;
9964
9965 default:
9966 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
9967 break;
9968 }
9969
9970 return 0; /* Should never be reached. */
9971}
9972
9973/* Same as ada_exception_name_addr_1, except that it intercepts and contains
9974 any error that ada_exception_name_addr_1 might cause to be thrown.
9975 When an error is intercepted, a warning with the error message is printed,
9976 and zero is returned. */
9977
9978static CORE_ADDR
9979ada_exception_name_addr (enum exception_catchpoint_kind ex,
9980 struct breakpoint *b)
9981{
9982 struct gdb_exception e;
9983 CORE_ADDR result = 0;
9984
9985 TRY_CATCH (e, RETURN_MASK_ERROR)
9986 {
9987 result = ada_exception_name_addr_1 (ex, b);
9988 }
9989
9990 if (e.reason < 0)
9991 {
9992 warning (_("failed to get exception name: %s"), e.message);
9993 return 0;
9994 }
9995
9996 return result;
9997}
9998
9999/* Implement the PRINT_IT method in the breakpoint_ops structure
10000 for all exception catchpoint kinds. */
10001
10002static enum print_stop_action
10003print_it_exception (enum exception_catchpoint_kind ex, struct breakpoint *b)
10004{
10005 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
10006 char exception_name[256];
10007
10008 if (addr != 0)
10009 {
10010 read_memory (addr, exception_name, sizeof (exception_name) - 1);
10011 exception_name [sizeof (exception_name) - 1] = '\0';
10012 }
10013
10014 ada_find_printable_frame (get_current_frame ());
10015
10016 annotate_catchpoint (b->number);
10017 switch (ex)
10018 {
10019 case ex_catch_exception:
10020 if (addr != 0)
10021 printf_filtered (_("\nCatchpoint %d, %s at "),
10022 b->number, exception_name);
10023 else
10024 printf_filtered (_("\nCatchpoint %d, exception at "), b->number);
10025 break;
10026 case ex_catch_exception_unhandled:
10027 if (addr != 0)
10028 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
10029 b->number, exception_name);
10030 else
10031 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
10032 b->number);
10033 break;
10034 case ex_catch_assert:
10035 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
10036 b->number);
10037 break;
10038 }
10039
10040 return PRINT_SRC_AND_LOC;
10041}
10042
10043/* Implement the PRINT_ONE method in the breakpoint_ops structure
10044 for all exception catchpoint kinds. */
10045
10046static void
10047print_one_exception (enum exception_catchpoint_kind ex,
10048 struct breakpoint *b, CORE_ADDR *last_addr)
10049{
79a45b7d
TT
10050 struct value_print_options opts;
10051
10052 get_user_print_options (&opts);
10053 if (opts.addressprint)
f7f9143b
JB
10054 {
10055 annotate_field (4);
10056 ui_out_field_core_addr (uiout, "addr", b->loc->address);
10057 }
10058
10059 annotate_field (5);
10060 *last_addr = b->loc->address;
10061 switch (ex)
10062 {
10063 case ex_catch_exception:
10064 if (b->exp_string != NULL)
10065 {
10066 char *msg = xstrprintf (_("`%s' Ada exception"), b->exp_string);
10067
10068 ui_out_field_string (uiout, "what", msg);
10069 xfree (msg);
10070 }
10071 else
10072 ui_out_field_string (uiout, "what", "all Ada exceptions");
10073
10074 break;
10075
10076 case ex_catch_exception_unhandled:
10077 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
10078 break;
10079
10080 case ex_catch_assert:
10081 ui_out_field_string (uiout, "what", "failed Ada assertions");
10082 break;
10083
10084 default:
10085 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10086 break;
10087 }
10088}
10089
10090/* Implement the PRINT_MENTION method in the breakpoint_ops structure
10091 for all exception catchpoint kinds. */
10092
10093static void
10094print_mention_exception (enum exception_catchpoint_kind ex,
10095 struct breakpoint *b)
10096{
10097 switch (ex)
10098 {
10099 case ex_catch_exception:
10100 if (b->exp_string != NULL)
10101 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
10102 b->number, b->exp_string);
10103 else
10104 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b->number);
10105
10106 break;
10107
10108 case ex_catch_exception_unhandled:
10109 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
10110 b->number);
10111 break;
10112
10113 case ex_catch_assert:
10114 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b->number);
10115 break;
10116
10117 default:
10118 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10119 break;
10120 }
10121}
10122
10123/* Virtual table for "catch exception" breakpoints. */
10124
10125static enum print_stop_action
10126print_it_catch_exception (struct breakpoint *b)
10127{
10128 return print_it_exception (ex_catch_exception, b);
10129}
10130
10131static void
10132print_one_catch_exception (struct breakpoint *b, CORE_ADDR *last_addr)
10133{
10134 print_one_exception (ex_catch_exception, b, last_addr);
10135}
10136
10137static void
10138print_mention_catch_exception (struct breakpoint *b)
10139{
10140 print_mention_exception (ex_catch_exception, b);
10141}
10142
10143static struct breakpoint_ops catch_exception_breakpoint_ops =
10144{
ce78b96d
JB
10145 NULL, /* insert */
10146 NULL, /* remove */
10147 NULL, /* breakpoint_hit */
f7f9143b
JB
10148 print_it_catch_exception,
10149 print_one_catch_exception,
10150 print_mention_catch_exception
10151};
10152
10153/* Virtual table for "catch exception unhandled" breakpoints. */
10154
10155static enum print_stop_action
10156print_it_catch_exception_unhandled (struct breakpoint *b)
10157{
10158 return print_it_exception (ex_catch_exception_unhandled, b);
10159}
10160
10161static void
10162print_one_catch_exception_unhandled (struct breakpoint *b, CORE_ADDR *last_addr)
10163{
10164 print_one_exception (ex_catch_exception_unhandled, b, last_addr);
10165}
10166
10167static void
10168print_mention_catch_exception_unhandled (struct breakpoint *b)
10169{
10170 print_mention_exception (ex_catch_exception_unhandled, b);
10171}
10172
10173static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops = {
ce78b96d
JB
10174 NULL, /* insert */
10175 NULL, /* remove */
10176 NULL, /* breakpoint_hit */
f7f9143b
JB
10177 print_it_catch_exception_unhandled,
10178 print_one_catch_exception_unhandled,
10179 print_mention_catch_exception_unhandled
10180};
10181
10182/* Virtual table for "catch assert" breakpoints. */
10183
10184static enum print_stop_action
10185print_it_catch_assert (struct breakpoint *b)
10186{
10187 return print_it_exception (ex_catch_assert, b);
10188}
10189
10190static void
10191print_one_catch_assert (struct breakpoint *b, CORE_ADDR *last_addr)
10192{
10193 print_one_exception (ex_catch_assert, b, last_addr);
10194}
10195
10196static void
10197print_mention_catch_assert (struct breakpoint *b)
10198{
10199 print_mention_exception (ex_catch_assert, b);
10200}
10201
10202static struct breakpoint_ops catch_assert_breakpoint_ops = {
ce78b96d
JB
10203 NULL, /* insert */
10204 NULL, /* remove */
10205 NULL, /* breakpoint_hit */
f7f9143b
JB
10206 print_it_catch_assert,
10207 print_one_catch_assert,
10208 print_mention_catch_assert
10209};
10210
10211/* Return non-zero if B is an Ada exception catchpoint. */
10212
10213int
10214ada_exception_catchpoint_p (struct breakpoint *b)
10215{
10216 return (b->ops == &catch_exception_breakpoint_ops
10217 || b->ops == &catch_exception_unhandled_breakpoint_ops
10218 || b->ops == &catch_assert_breakpoint_ops);
10219}
10220
f7f9143b
JB
10221/* Return a newly allocated copy of the first space-separated token
10222 in ARGSP, and then adjust ARGSP to point immediately after that
10223 token.
10224
10225 Return NULL if ARGPS does not contain any more tokens. */
10226
10227static char *
10228ada_get_next_arg (char **argsp)
10229{
10230 char *args = *argsp;
10231 char *end;
10232 char *result;
10233
10234 /* Skip any leading white space. */
10235
10236 while (isspace (*args))
10237 args++;
10238
10239 if (args[0] == '\0')
10240 return NULL; /* No more arguments. */
10241
10242 /* Find the end of the current argument. */
10243
10244 end = args;
10245 while (*end != '\0' && !isspace (*end))
10246 end++;
10247
10248 /* Adjust ARGSP to point to the start of the next argument. */
10249
10250 *argsp = end;
10251
10252 /* Make a copy of the current argument and return it. */
10253
10254 result = xmalloc (end - args + 1);
10255 strncpy (result, args, end - args);
10256 result[end - args] = '\0';
10257
10258 return result;
10259}
10260
10261/* Split the arguments specified in a "catch exception" command.
10262 Set EX to the appropriate catchpoint type.
10263 Set EXP_STRING to the name of the specific exception if
10264 specified by the user. */
10265
10266static void
10267catch_ada_exception_command_split (char *args,
10268 enum exception_catchpoint_kind *ex,
10269 char **exp_string)
10270{
10271 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
10272 char *exception_name;
10273
10274 exception_name = ada_get_next_arg (&args);
10275 make_cleanup (xfree, exception_name);
10276
10277 /* Check that we do not have any more arguments. Anything else
10278 is unexpected. */
10279
10280 while (isspace (*args))
10281 args++;
10282
10283 if (args[0] != '\0')
10284 error (_("Junk at end of expression"));
10285
10286 discard_cleanups (old_chain);
10287
10288 if (exception_name == NULL)
10289 {
10290 /* Catch all exceptions. */
10291 *ex = ex_catch_exception;
10292 *exp_string = NULL;
10293 }
10294 else if (strcmp (exception_name, "unhandled") == 0)
10295 {
10296 /* Catch unhandled exceptions. */
10297 *ex = ex_catch_exception_unhandled;
10298 *exp_string = NULL;
10299 }
10300 else
10301 {
10302 /* Catch a specific exception. */
10303 *ex = ex_catch_exception;
10304 *exp_string = exception_name;
10305 }
10306}
10307
10308/* Return the name of the symbol on which we should break in order to
10309 implement a catchpoint of the EX kind. */
10310
10311static const char *
10312ada_exception_sym_name (enum exception_catchpoint_kind ex)
10313{
0259addd
JB
10314 gdb_assert (exception_info != NULL);
10315
f7f9143b
JB
10316 switch (ex)
10317 {
10318 case ex_catch_exception:
0259addd 10319 return (exception_info->catch_exception_sym);
f7f9143b
JB
10320 break;
10321 case ex_catch_exception_unhandled:
0259addd 10322 return (exception_info->catch_exception_unhandled_sym);
f7f9143b
JB
10323 break;
10324 case ex_catch_assert:
0259addd 10325 return (exception_info->catch_assert_sym);
f7f9143b
JB
10326 break;
10327 default:
10328 internal_error (__FILE__, __LINE__,
10329 _("unexpected catchpoint kind (%d)"), ex);
10330 }
10331}
10332
10333/* Return the breakpoint ops "virtual table" used for catchpoints
10334 of the EX kind. */
10335
10336static struct breakpoint_ops *
4b9eee8c 10337ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex)
f7f9143b
JB
10338{
10339 switch (ex)
10340 {
10341 case ex_catch_exception:
10342 return (&catch_exception_breakpoint_ops);
10343 break;
10344 case ex_catch_exception_unhandled:
10345 return (&catch_exception_unhandled_breakpoint_ops);
10346 break;
10347 case ex_catch_assert:
10348 return (&catch_assert_breakpoint_ops);
10349 break;
10350 default:
10351 internal_error (__FILE__, __LINE__,
10352 _("unexpected catchpoint kind (%d)"), ex);
10353 }
10354}
10355
10356/* Return the condition that will be used to match the current exception
10357 being raised with the exception that the user wants to catch. This
10358 assumes that this condition is used when the inferior just triggered
10359 an exception catchpoint.
10360
10361 The string returned is a newly allocated string that needs to be
10362 deallocated later. */
10363
10364static char *
10365ada_exception_catchpoint_cond_string (const char *exp_string)
10366{
3d0b0fa3
JB
10367 int i;
10368
10369 /* The standard exceptions are a special case. They are defined in
10370 runtime units that have been compiled without debugging info; if
10371 EXP_STRING is the not-fully-qualified name of a standard
10372 exception (e.g. "constraint_error") then, during the evaluation
10373 of the condition expression, the symbol lookup on this name would
10374 *not* return this standard exception. The catchpoint condition
10375 may then be set only on user-defined exceptions which have the
10376 same not-fully-qualified name (e.g. my_package.constraint_error).
10377
10378 To avoid this unexcepted behavior, these standard exceptions are
10379 systematically prefixed by "standard". This means that "catch
10380 exception constraint_error" is rewritten into "catch exception
10381 standard.constraint_error".
10382
10383 If an exception named contraint_error is defined in another package of
10384 the inferior program, then the only way to specify this exception as a
10385 breakpoint condition is to use its fully-qualified named:
10386 e.g. my_package.constraint_error. */
10387
10388 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
10389 {
10390 if (strcmp (standard_exc [i], exp_string) == 0)
10391 {
10392 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
10393 exp_string);
10394 }
10395 }
f7f9143b
JB
10396 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string);
10397}
10398
10399/* Return the expression corresponding to COND_STRING evaluated at SAL. */
10400
10401static struct expression *
10402ada_parse_catchpoint_condition (char *cond_string,
10403 struct symtab_and_line sal)
10404{
10405 return (parse_exp_1 (&cond_string, block_for_pc (sal.pc), 0));
10406}
10407
10408/* Return the symtab_and_line that should be used to insert an exception
10409 catchpoint of the TYPE kind.
10410
10411 EX_STRING should contain the name of a specific exception
10412 that the catchpoint should catch, or NULL otherwise.
10413
10414 The idea behind all the remaining parameters is that their names match
10415 the name of certain fields in the breakpoint structure that are used to
10416 handle exception catchpoints. This function returns the value to which
10417 these fields should be set, depending on the type of catchpoint we need
10418 to create.
10419
10420 If COND and COND_STRING are both non-NULL, any value they might
10421 hold will be free'ed, and then replaced by newly allocated ones.
10422 These parameters are left untouched otherwise. */
10423
10424static struct symtab_and_line
10425ada_exception_sal (enum exception_catchpoint_kind ex, char *exp_string,
10426 char **addr_string, char **cond_string,
10427 struct expression **cond, struct breakpoint_ops **ops)
10428{
10429 const char *sym_name;
10430 struct symbol *sym;
10431 struct symtab_and_line sal;
10432
0259addd
JB
10433 /* First, find out which exception support info to use. */
10434 ada_exception_support_info_sniffer ();
10435
10436 /* Then lookup the function on which we will break in order to catch
f7f9143b
JB
10437 the Ada exceptions requested by the user. */
10438
10439 sym_name = ada_exception_sym_name (ex);
10440 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
10441
10442 /* The symbol we're looking up is provided by a unit in the GNAT runtime
10443 that should be compiled with debugging information. As a result, we
10444 expect to find that symbol in the symtabs. If we don't find it, then
10445 the target most likely does not support Ada exceptions, or we cannot
10446 insert exception breakpoints yet, because the GNAT runtime hasn't been
10447 loaded yet. */
10448
10449 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
10450 in such a way that no debugging information is produced for the symbol
10451 we are looking for. In this case, we could search the minimal symbols
10452 as a fall-back mechanism. This would still be operating in degraded
10453 mode, however, as we would still be missing the debugging information
10454 that is needed in order to extract the name of the exception being
10455 raised (this name is printed in the catchpoint message, and is also
10456 used when trying to catch a specific exception). We do not handle
10457 this case for now. */
10458
10459 if (sym == NULL)
0259addd 10460 error (_("Unable to break on '%s' in this configuration."), sym_name);
f7f9143b
JB
10461
10462 /* Make sure that the symbol we found corresponds to a function. */
10463 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
10464 error (_("Symbol \"%s\" is not a function (class = %d)"),
10465 sym_name, SYMBOL_CLASS (sym));
10466
10467 sal = find_function_start_sal (sym, 1);
10468
10469 /* Set ADDR_STRING. */
10470
10471 *addr_string = xstrdup (sym_name);
10472
10473 /* Set the COND and COND_STRING (if not NULL). */
10474
10475 if (cond_string != NULL && cond != NULL)
10476 {
10477 if (*cond_string != NULL)
10478 {
10479 xfree (*cond_string);
10480 *cond_string = NULL;
10481 }
10482 if (*cond != NULL)
10483 {
10484 xfree (*cond);
10485 *cond = NULL;
10486 }
10487 if (exp_string != NULL)
10488 {
10489 *cond_string = ada_exception_catchpoint_cond_string (exp_string);
10490 *cond = ada_parse_catchpoint_condition (*cond_string, sal);
10491 }
10492 }
10493
10494 /* Set OPS. */
4b9eee8c 10495 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b
JB
10496
10497 return sal;
10498}
10499
10500/* Parse the arguments (ARGS) of the "catch exception" command.
10501
10502 Set TYPE to the appropriate exception catchpoint type.
10503 If the user asked the catchpoint to catch only a specific
10504 exception, then save the exception name in ADDR_STRING.
10505
10506 See ada_exception_sal for a description of all the remaining
10507 function arguments of this function. */
10508
10509struct symtab_and_line
10510ada_decode_exception_location (char *args, char **addr_string,
10511 char **exp_string, char **cond_string,
10512 struct expression **cond,
10513 struct breakpoint_ops **ops)
10514{
10515 enum exception_catchpoint_kind ex;
10516
10517 catch_ada_exception_command_split (args, &ex, exp_string);
10518 return ada_exception_sal (ex, *exp_string, addr_string, cond_string,
10519 cond, ops);
10520}
10521
10522struct symtab_and_line
10523ada_decode_assert_location (char *args, char **addr_string,
10524 struct breakpoint_ops **ops)
10525{
10526 /* Check that no argument where provided at the end of the command. */
10527
10528 if (args != NULL)
10529 {
10530 while (isspace (*args))
10531 args++;
10532 if (*args != '\0')
10533 error (_("Junk at end of arguments."));
10534 }
10535
10536 return ada_exception_sal (ex_catch_assert, NULL, addr_string, NULL, NULL,
10537 ops);
10538}
10539
4c4b4cd2
PH
10540 /* Operators */
10541/* Information about operators given special treatment in functions
10542 below. */
10543/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
10544
10545#define ADA_OPERATORS \
10546 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
10547 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
10548 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
10549 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
10550 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
10551 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
10552 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
10553 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
10554 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
10555 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
10556 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
10557 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
10558 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
10559 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
10560 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
10561 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
10562 OP_DEFN (OP_OTHERS, 1, 1, 0) \
10563 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
10564 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
10565
10566static void
10567ada_operator_length (struct expression *exp, int pc, int *oplenp, int *argsp)
10568{
10569 switch (exp->elts[pc - 1].opcode)
10570 {
76a01679 10571 default:
4c4b4cd2
PH
10572 operator_length_standard (exp, pc, oplenp, argsp);
10573 break;
10574
10575#define OP_DEFN(op, len, args, binop) \
10576 case op: *oplenp = len; *argsp = args; break;
10577 ADA_OPERATORS;
10578#undef OP_DEFN
52ce6436
PH
10579
10580 case OP_AGGREGATE:
10581 *oplenp = 3;
10582 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
10583 break;
10584
10585 case OP_CHOICES:
10586 *oplenp = 3;
10587 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
10588 break;
4c4b4cd2
PH
10589 }
10590}
10591
10592static char *
10593ada_op_name (enum exp_opcode opcode)
10594{
10595 switch (opcode)
10596 {
76a01679 10597 default:
4c4b4cd2 10598 return op_name_standard (opcode);
52ce6436 10599
4c4b4cd2
PH
10600#define OP_DEFN(op, len, args, binop) case op: return #op;
10601 ADA_OPERATORS;
10602#undef OP_DEFN
52ce6436
PH
10603
10604 case OP_AGGREGATE:
10605 return "OP_AGGREGATE";
10606 case OP_CHOICES:
10607 return "OP_CHOICES";
10608 case OP_NAME:
10609 return "OP_NAME";
4c4b4cd2
PH
10610 }
10611}
10612
10613/* As for operator_length, but assumes PC is pointing at the first
10614 element of the operator, and gives meaningful results only for the
52ce6436 10615 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
10616
10617static void
76a01679
JB
10618ada_forward_operator_length (struct expression *exp, int pc,
10619 int *oplenp, int *argsp)
4c4b4cd2 10620{
76a01679 10621 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
10622 {
10623 default:
10624 *oplenp = *argsp = 0;
10625 break;
52ce6436 10626
4c4b4cd2
PH
10627#define OP_DEFN(op, len, args, binop) \
10628 case op: *oplenp = len; *argsp = args; break;
10629 ADA_OPERATORS;
10630#undef OP_DEFN
52ce6436
PH
10631
10632 case OP_AGGREGATE:
10633 *oplenp = 3;
10634 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
10635 break;
10636
10637 case OP_CHOICES:
10638 *oplenp = 3;
10639 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
10640 break;
10641
10642 case OP_STRING:
10643 case OP_NAME:
10644 {
10645 int len = longest_to_int (exp->elts[pc + 1].longconst);
10646 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
10647 *argsp = 0;
10648 break;
10649 }
4c4b4cd2
PH
10650 }
10651}
10652
10653static int
10654ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
10655{
10656 enum exp_opcode op = exp->elts[elt].opcode;
10657 int oplen, nargs;
10658 int pc = elt;
10659 int i;
76a01679 10660
4c4b4cd2
PH
10661 ada_forward_operator_length (exp, elt, &oplen, &nargs);
10662
76a01679 10663 switch (op)
4c4b4cd2 10664 {
76a01679 10665 /* Ada attributes ('Foo). */
4c4b4cd2
PH
10666 case OP_ATR_FIRST:
10667 case OP_ATR_LAST:
10668 case OP_ATR_LENGTH:
10669 case OP_ATR_IMAGE:
10670 case OP_ATR_MAX:
10671 case OP_ATR_MIN:
10672 case OP_ATR_MODULUS:
10673 case OP_ATR_POS:
10674 case OP_ATR_SIZE:
10675 case OP_ATR_TAG:
10676 case OP_ATR_VAL:
10677 break;
10678
10679 case UNOP_IN_RANGE:
10680 case UNOP_QUAL:
323e0a4a
AC
10681 /* XXX: gdb_sprint_host_address, type_sprint */
10682 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
10683 gdb_print_host_address (exp->elts[pc + 1].type, stream);
10684 fprintf_filtered (stream, " (");
10685 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
10686 fprintf_filtered (stream, ")");
10687 break;
10688 case BINOP_IN_BOUNDS:
52ce6436
PH
10689 fprintf_filtered (stream, " (%d)",
10690 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
10691 break;
10692 case TERNOP_IN_RANGE:
10693 break;
10694
52ce6436
PH
10695 case OP_AGGREGATE:
10696 case OP_OTHERS:
10697 case OP_DISCRETE_RANGE:
10698 case OP_POSITIONAL:
10699 case OP_CHOICES:
10700 break;
10701
10702 case OP_NAME:
10703 case OP_STRING:
10704 {
10705 char *name = &exp->elts[elt + 2].string;
10706 int len = longest_to_int (exp->elts[elt + 1].longconst);
10707 fprintf_filtered (stream, "Text: `%.*s'", len, name);
10708 break;
10709 }
10710
4c4b4cd2
PH
10711 default:
10712 return dump_subexp_body_standard (exp, stream, elt);
10713 }
10714
10715 elt += oplen;
10716 for (i = 0; i < nargs; i += 1)
10717 elt = dump_subexp (exp, stream, elt);
10718
10719 return elt;
10720}
10721
10722/* The Ada extension of print_subexp (q.v.). */
10723
76a01679
JB
10724static void
10725ada_print_subexp (struct expression *exp, int *pos,
10726 struct ui_file *stream, enum precedence prec)
4c4b4cd2 10727{
52ce6436 10728 int oplen, nargs, i;
4c4b4cd2
PH
10729 int pc = *pos;
10730 enum exp_opcode op = exp->elts[pc].opcode;
10731
10732 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10733
52ce6436 10734 *pos += oplen;
4c4b4cd2
PH
10735 switch (op)
10736 {
10737 default:
52ce6436 10738 *pos -= oplen;
4c4b4cd2
PH
10739 print_subexp_standard (exp, pos, stream, prec);
10740 return;
10741
10742 case OP_VAR_VALUE:
4c4b4cd2
PH
10743 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
10744 return;
10745
10746 case BINOP_IN_BOUNDS:
323e0a4a 10747 /* XXX: sprint_subexp */
4c4b4cd2 10748 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 10749 fputs_filtered (" in ", stream);
4c4b4cd2 10750 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 10751 fputs_filtered ("'range", stream);
4c4b4cd2 10752 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
10753 fprintf_filtered (stream, "(%ld)",
10754 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
10755 return;
10756
10757 case TERNOP_IN_RANGE:
4c4b4cd2 10758 if (prec >= PREC_EQUAL)
76a01679 10759 fputs_filtered ("(", stream);
323e0a4a 10760 /* XXX: sprint_subexp */
4c4b4cd2 10761 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 10762 fputs_filtered (" in ", stream);
4c4b4cd2
PH
10763 print_subexp (exp, pos, stream, PREC_EQUAL);
10764 fputs_filtered (" .. ", stream);
10765 print_subexp (exp, pos, stream, PREC_EQUAL);
10766 if (prec >= PREC_EQUAL)
76a01679
JB
10767 fputs_filtered (")", stream);
10768 return;
4c4b4cd2
PH
10769
10770 case OP_ATR_FIRST:
10771 case OP_ATR_LAST:
10772 case OP_ATR_LENGTH:
10773 case OP_ATR_IMAGE:
10774 case OP_ATR_MAX:
10775 case OP_ATR_MIN:
10776 case OP_ATR_MODULUS:
10777 case OP_ATR_POS:
10778 case OP_ATR_SIZE:
10779 case OP_ATR_TAG:
10780 case OP_ATR_VAL:
4c4b4cd2 10781 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
10782 {
10783 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
10784 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0);
10785 *pos += 3;
10786 }
4c4b4cd2 10787 else
76a01679 10788 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
10789 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
10790 if (nargs > 1)
76a01679
JB
10791 {
10792 int tem;
10793 for (tem = 1; tem < nargs; tem += 1)
10794 {
10795 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
10796 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
10797 }
10798 fputs_filtered (")", stream);
10799 }
4c4b4cd2 10800 return;
14f9c5c9 10801
4c4b4cd2 10802 case UNOP_QUAL:
4c4b4cd2
PH
10803 type_print (exp->elts[pc + 1].type, "", stream, 0);
10804 fputs_filtered ("'(", stream);
10805 print_subexp (exp, pos, stream, PREC_PREFIX);
10806 fputs_filtered (")", stream);
10807 return;
14f9c5c9 10808
4c4b4cd2 10809 case UNOP_IN_RANGE:
323e0a4a 10810 /* XXX: sprint_subexp */
4c4b4cd2 10811 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 10812 fputs_filtered (" in ", stream);
4c4b4cd2
PH
10813 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0);
10814 return;
52ce6436
PH
10815
10816 case OP_DISCRETE_RANGE:
10817 print_subexp (exp, pos, stream, PREC_SUFFIX);
10818 fputs_filtered ("..", stream);
10819 print_subexp (exp, pos, stream, PREC_SUFFIX);
10820 return;
10821
10822 case OP_OTHERS:
10823 fputs_filtered ("others => ", stream);
10824 print_subexp (exp, pos, stream, PREC_SUFFIX);
10825 return;
10826
10827 case OP_CHOICES:
10828 for (i = 0; i < nargs-1; i += 1)
10829 {
10830 if (i > 0)
10831 fputs_filtered ("|", stream);
10832 print_subexp (exp, pos, stream, PREC_SUFFIX);
10833 }
10834 fputs_filtered (" => ", stream);
10835 print_subexp (exp, pos, stream, PREC_SUFFIX);
10836 return;
10837
10838 case OP_POSITIONAL:
10839 print_subexp (exp, pos, stream, PREC_SUFFIX);
10840 return;
10841
10842 case OP_AGGREGATE:
10843 fputs_filtered ("(", stream);
10844 for (i = 0; i < nargs; i += 1)
10845 {
10846 if (i > 0)
10847 fputs_filtered (", ", stream);
10848 print_subexp (exp, pos, stream, PREC_SUFFIX);
10849 }
10850 fputs_filtered (")", stream);
10851 return;
4c4b4cd2
PH
10852 }
10853}
14f9c5c9
AS
10854
10855/* Table mapping opcodes into strings for printing operators
10856 and precedences of the operators. */
10857
d2e4a39e
AS
10858static const struct op_print ada_op_print_tab[] = {
10859 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
10860 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
10861 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
10862 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
10863 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
10864 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
10865 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
10866 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
10867 {"<=", BINOP_LEQ, PREC_ORDER, 0},
10868 {">=", BINOP_GEQ, PREC_ORDER, 0},
10869 {">", BINOP_GTR, PREC_ORDER, 0},
10870 {"<", BINOP_LESS, PREC_ORDER, 0},
10871 {">>", BINOP_RSH, PREC_SHIFT, 0},
10872 {"<<", BINOP_LSH, PREC_SHIFT, 0},
10873 {"+", BINOP_ADD, PREC_ADD, 0},
10874 {"-", BINOP_SUB, PREC_ADD, 0},
10875 {"&", BINOP_CONCAT, PREC_ADD, 0},
10876 {"*", BINOP_MUL, PREC_MUL, 0},
10877 {"/", BINOP_DIV, PREC_MUL, 0},
10878 {"rem", BINOP_REM, PREC_MUL, 0},
10879 {"mod", BINOP_MOD, PREC_MUL, 0},
10880 {"**", BINOP_EXP, PREC_REPEAT, 0},
10881 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
10882 {"-", UNOP_NEG, PREC_PREFIX, 0},
10883 {"+", UNOP_PLUS, PREC_PREFIX, 0},
10884 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
10885 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
10886 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
10887 {".all", UNOP_IND, PREC_SUFFIX, 1},
10888 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
10889 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
d2e4a39e 10890 {NULL, 0, 0, 0}
14f9c5c9
AS
10891};
10892\f
72d5681a
PH
10893enum ada_primitive_types {
10894 ada_primitive_type_int,
10895 ada_primitive_type_long,
10896 ada_primitive_type_short,
10897 ada_primitive_type_char,
10898 ada_primitive_type_float,
10899 ada_primitive_type_double,
10900 ada_primitive_type_void,
10901 ada_primitive_type_long_long,
10902 ada_primitive_type_long_double,
10903 ada_primitive_type_natural,
10904 ada_primitive_type_positive,
10905 ada_primitive_type_system_address,
10906 nr_ada_primitive_types
10907};
6c038f32
PH
10908
10909static void
d4a9a881 10910ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
10911 struct language_arch_info *lai)
10912{
d4a9a881 10913 const struct builtin_type *builtin = builtin_type (gdbarch);
72d5681a 10914 lai->primitive_type_vector
d4a9a881 10915 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a
PH
10916 struct type *);
10917 lai->primitive_type_vector [ada_primitive_type_int] =
9a76efb6 10918 init_type (TYPE_CODE_INT,
d4a9a881 10919 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
9a76efb6 10920 0, "integer", (struct objfile *) NULL);
72d5681a 10921 lai->primitive_type_vector [ada_primitive_type_long] =
9a76efb6 10922 init_type (TYPE_CODE_INT,
d4a9a881 10923 gdbarch_long_bit (gdbarch) / TARGET_CHAR_BIT,
9a76efb6 10924 0, "long_integer", (struct objfile *) NULL);
72d5681a 10925 lai->primitive_type_vector [ada_primitive_type_short] =
9a76efb6 10926 init_type (TYPE_CODE_INT,
d4a9a881 10927 gdbarch_short_bit (gdbarch) / TARGET_CHAR_BIT,
9a76efb6 10928 0, "short_integer", (struct objfile *) NULL);
61ee279c
PH
10929 lai->string_char_type =
10930 lai->primitive_type_vector [ada_primitive_type_char] =
6c038f32
PH
10931 init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
10932 0, "character", (struct objfile *) NULL);
72d5681a 10933 lai->primitive_type_vector [ada_primitive_type_float] =
ea06eb3d 10934 init_type (TYPE_CODE_FLT,
d4a9a881 10935 gdbarch_float_bit (gdbarch)/ TARGET_CHAR_BIT,
6c038f32 10936 0, "float", (struct objfile *) NULL);
72d5681a 10937 lai->primitive_type_vector [ada_primitive_type_double] =
ea06eb3d 10938 init_type (TYPE_CODE_FLT,
d4a9a881 10939 gdbarch_double_bit (gdbarch) / TARGET_CHAR_BIT,
6c038f32 10940 0, "long_float", (struct objfile *) NULL);
72d5681a 10941 lai->primitive_type_vector [ada_primitive_type_long_long] =
9a76efb6 10942 init_type (TYPE_CODE_INT,
d4a9a881 10943 gdbarch_long_long_bit (gdbarch) / TARGET_CHAR_BIT,
6c038f32 10944 0, "long_long_integer", (struct objfile *) NULL);
72d5681a 10945 lai->primitive_type_vector [ada_primitive_type_long_double] =
ea06eb3d 10946 init_type (TYPE_CODE_FLT,
d4a9a881 10947 gdbarch_double_bit (gdbarch) / TARGET_CHAR_BIT,
6c038f32 10948 0, "long_long_float", (struct objfile *) NULL);
72d5681a 10949 lai->primitive_type_vector [ada_primitive_type_natural] =
9a76efb6 10950 init_type (TYPE_CODE_INT,
d4a9a881 10951 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
9a76efb6 10952 0, "natural", (struct objfile *) NULL);
72d5681a 10953 lai->primitive_type_vector [ada_primitive_type_positive] =
9a76efb6 10954 init_type (TYPE_CODE_INT,
d4a9a881 10955 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
9a76efb6 10956 0, "positive", (struct objfile *) NULL);
72d5681a 10957 lai->primitive_type_vector [ada_primitive_type_void] = builtin->builtin_void;
6c038f32 10958
72d5681a 10959 lai->primitive_type_vector [ada_primitive_type_system_address] =
6c038f32
PH
10960 lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
10961 (struct objfile *) NULL));
72d5681a
PH
10962 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
10963 = "system__address";
fbb06eb1 10964
47e729a8 10965 lai->bool_type_symbol = NULL;
fbb06eb1 10966 lai->bool_type_default = builtin->builtin_bool;
6c038f32 10967}
6c038f32
PH
10968\f
10969 /* Language vector */
10970
10971/* Not really used, but needed in the ada_language_defn. */
10972
10973static void
6c7a06a3 10974emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 10975{
6c7a06a3 10976 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
10977}
10978
10979static int
10980parse (void)
10981{
10982 warnings_issued = 0;
10983 return ada_parse ();
10984}
10985
10986static const struct exp_descriptor ada_exp_descriptor = {
10987 ada_print_subexp,
10988 ada_operator_length,
10989 ada_op_name,
10990 ada_dump_subexp_body,
10991 ada_evaluate_subexp
10992};
10993
10994const struct language_defn ada_language_defn = {
10995 "ada", /* Language name */
10996 language_ada,
6c038f32
PH
10997 range_check_off,
10998 type_check_off,
10999 case_sensitive_on, /* Yes, Ada is case-insensitive, but
11000 that's not quite what this means. */
6c038f32 11001 array_row_major,
9a044a89 11002 macro_expansion_no,
6c038f32
PH
11003 &ada_exp_descriptor,
11004 parse,
11005 ada_error,
11006 resolve,
11007 ada_printchar, /* Print a character constant */
11008 ada_printstr, /* Function to print string constant */
11009 emit_char, /* Function to print single char (not used) */
6c038f32 11010 ada_print_type, /* Print a type using appropriate syntax */
5c6ce71d 11011 default_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
11012 ada_val_print, /* Print a value using appropriate syntax */
11013 ada_value_print, /* Print a top-level value */
11014 NULL, /* Language specific skip_trampoline */
2b2d9e11 11015 NULL, /* name_of_this */
6c038f32
PH
11016 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
11017 basic_lookup_transparent_type, /* lookup_transparent_type */
11018 ada_la_decode, /* Language specific symbol demangler */
11019 NULL, /* Language specific class_name_from_physname */
11020 ada_op_print_tab, /* expression operators for printing */
11021 0, /* c-style arrays */
11022 1, /* String lower bound */
6c038f32 11023 ada_get_gdb_completer_word_break_characters,
41d27058 11024 ada_make_symbol_completion_list,
72d5681a 11025 ada_language_arch_info,
e79af960 11026 ada_print_array_index,
41f1b697 11027 default_pass_by_reference,
ae6a3a4c 11028 c_get_string,
6c038f32
PH
11029 LANG_MAGIC
11030};
11031
2c0b251b
PA
11032/* Provide a prototype to silence -Wmissing-prototypes. */
11033extern initialize_file_ftype _initialize_ada_language;
11034
d2e4a39e 11035void
6c038f32 11036_initialize_ada_language (void)
14f9c5c9 11037{
6c038f32
PH
11038 add_language (&ada_language_defn);
11039
11040 varsize_limit = 65536;
6c038f32
PH
11041
11042 obstack_init (&symbol_list_obstack);
11043
11044 decoded_names_store = htab_create_alloc
11045 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
11046 NULL, xcalloc, xfree);
6b69afc4
JB
11047
11048 observer_attach_executable_changed (ada_executable_changed_observer);
14f9c5c9 11049}