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