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