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