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