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