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