]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
(scan_xcoff_symtab): Do not include global symbols
[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;
aced2898 2255 int from_size;
d2e4a39e
AS
2256 char *buffer = (char *) alloca (len);
2257 struct value *val;
52ce6436 2258 CORE_ADDR to_addr = VALUE_ADDRESS (toval) + value_offset (toval);
14f9c5c9
AS
2259
2260 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2261 fromval = value_cast (type, fromval);
14f9c5c9 2262
52ce6436 2263 read_memory (to_addr, buffer, len);
aced2898
PH
2264 from_size = value_bitsize (fromval);
2265 if (from_size == 0)
2266 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
32c9a795 2267 if (gdbarch_bits_big_endian (current_gdbarch))
df407dfe 2268 move_bits (buffer, value_bitpos (toval),
aced2898 2269 value_contents (fromval), from_size - bits, bits);
14f9c5c9 2270 else
0fd88904 2271 move_bits (buffer, value_bitpos (toval), value_contents (fromval),
4c4b4cd2 2272 0, bits);
52ce6436
PH
2273 write_memory (to_addr, buffer, len);
2274 if (deprecated_memory_changed_hook)
2275 deprecated_memory_changed_hook (to_addr, len);
2276
14f9c5c9 2277 val = value_copy (toval);
0fd88904 2278 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2279 TYPE_LENGTH (type));
04624583 2280 deprecated_set_value_type (val, type);
d2e4a39e 2281
14f9c5c9
AS
2282 return val;
2283 }
2284
2285 return value_assign (toval, fromval);
2286}
2287
2288
52ce6436
PH
2289/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2290 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2291 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2292 * COMPONENT, and not the inferior's memory. The current contents
2293 * of COMPONENT are ignored. */
2294static void
2295value_assign_to_component (struct value *container, struct value *component,
2296 struct value *val)
2297{
2298 LONGEST offset_in_container =
2299 (LONGEST) (VALUE_ADDRESS (component) + value_offset (component)
2300 - VALUE_ADDRESS (container) - value_offset (container));
2301 int bit_offset_in_container =
2302 value_bitpos (component) - value_bitpos (container);
2303 int bits;
2304
2305 val = value_cast (value_type (component), val);
2306
2307 if (value_bitsize (component) == 0)
2308 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2309 else
2310 bits = value_bitsize (component);
2311
32c9a795 2312 if (gdbarch_bits_big_endian (current_gdbarch))
52ce6436
PH
2313 move_bits (value_contents_writeable (container) + offset_in_container,
2314 value_bitpos (container) + bit_offset_in_container,
2315 value_contents (val),
2316 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2317 bits);
2318 else
2319 move_bits (value_contents_writeable (container) + offset_in_container,
2320 value_bitpos (container) + bit_offset_in_container,
2321 value_contents (val), 0, bits);
2322}
2323
4c4b4cd2
PH
2324/* The value of the element of array ARR at the ARITY indices given in IND.
2325 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2326 thereto. */
2327
d2e4a39e
AS
2328struct value *
2329ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2330{
2331 int k;
d2e4a39e
AS
2332 struct value *elt;
2333 struct type *elt_type;
14f9c5c9
AS
2334
2335 elt = ada_coerce_to_simple_array (arr);
2336
df407dfe 2337 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2338 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2339 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2340 return value_subscript_packed (elt, arity, ind);
2341
2342 for (k = 0; k < arity; k += 1)
2343 {
2344 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2345 error (_("too many subscripts (%d expected)"), k);
14f9c5c9
AS
2346 elt = value_subscript (elt, value_pos_atr (ind[k]));
2347 }
2348 return elt;
2349}
2350
2351/* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2352 value of the element of *ARR at the ARITY indices given in
4c4b4cd2 2353 IND. Does not read the entire array into memory. */
14f9c5c9 2354
d2e4a39e
AS
2355struct value *
2356ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
4c4b4cd2 2357 struct value **ind)
14f9c5c9
AS
2358{
2359 int k;
2360
2361 for (k = 0; k < arity; k += 1)
2362 {
2363 LONGEST lwb, upb;
d2e4a39e 2364 struct value *idx;
14f9c5c9
AS
2365
2366 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2367 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2368 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2369 value_copy (arr));
14f9c5c9 2370 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
4c4b4cd2
PH
2371 idx = value_pos_atr (ind[k]);
2372 if (lwb != 0)
2373 idx = value_sub (idx, value_from_longest (builtin_type_int, lwb));
14f9c5c9
AS
2374 arr = value_add (arr, idx);
2375 type = TYPE_TARGET_TYPE (type);
2376 }
2377
2378 return value_ind (arr);
2379}
2380
0b5d8877
PH
2381/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2382 actual type of ARRAY_PTR is ignored), returns a reference to
2383 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2384 bound of this array is LOW, as per Ada rules. */
2385static struct value *
6c038f32 2386ada_value_slice_ptr (struct value *array_ptr, struct type *type,
0b5d8877
PH
2387 int low, int high)
2388{
6c038f32 2389 CORE_ADDR base = value_as_address (array_ptr)
0b5d8877
PH
2390 + ((low - TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type)))
2391 * TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
6c038f32
PH
2392 struct type *index_type =
2393 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type)),
0b5d8877 2394 low, high);
6c038f32 2395 struct type *slice_type =
0b5d8877
PH
2396 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2397 return value_from_pointer (lookup_reference_type (slice_type), base);
2398}
2399
2400
2401static struct value *
2402ada_value_slice (struct value *array, int low, int high)
2403{
df407dfe 2404 struct type *type = value_type (array);
6c038f32 2405 struct type *index_type =
0b5d8877 2406 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
6c038f32 2407 struct type *slice_type =
0b5d8877 2408 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
6c038f32 2409 return value_cast (slice_type, value_slice (array, low, high - low + 1));
0b5d8877
PH
2410}
2411
14f9c5c9
AS
2412/* If type is a record type in the form of a standard GNAT array
2413 descriptor, returns the number of dimensions for type. If arr is a
2414 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2415 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2416
2417int
d2e4a39e 2418ada_array_arity (struct type *type)
14f9c5c9
AS
2419{
2420 int arity;
2421
2422 if (type == NULL)
2423 return 0;
2424
2425 type = desc_base_type (type);
2426
2427 arity = 0;
d2e4a39e 2428 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2429 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2430 else
2431 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2432 {
4c4b4cd2 2433 arity += 1;
61ee279c 2434 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2435 }
d2e4a39e 2436
14f9c5c9
AS
2437 return arity;
2438}
2439
2440/* If TYPE is a record type in the form of a standard GNAT array
2441 descriptor or a simple array type, returns the element type for
2442 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2443 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2444
d2e4a39e
AS
2445struct type *
2446ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2447{
2448 type = desc_base_type (type);
2449
d2e4a39e 2450 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2451 {
2452 int k;
d2e4a39e 2453 struct type *p_array_type;
14f9c5c9
AS
2454
2455 p_array_type = desc_data_type (type);
2456
2457 k = ada_array_arity (type);
2458 if (k == 0)
4c4b4cd2 2459 return NULL;
d2e4a39e 2460
4c4b4cd2 2461 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2462 if (nindices >= 0 && k > nindices)
4c4b4cd2 2463 k = nindices;
14f9c5c9 2464 p_array_type = TYPE_TARGET_TYPE (p_array_type);
d2e4a39e 2465 while (k > 0 && p_array_type != NULL)
4c4b4cd2 2466 {
61ee279c 2467 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
2468 k -= 1;
2469 }
14f9c5c9
AS
2470 return p_array_type;
2471 }
2472 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2473 {
2474 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
2475 {
2476 type = TYPE_TARGET_TYPE (type);
2477 nindices -= 1;
2478 }
14f9c5c9
AS
2479 return type;
2480 }
2481
2482 return NULL;
2483}
2484
4c4b4cd2
PH
2485/* The type of nth index in arrays of given type (n numbering from 1).
2486 Does not examine memory. */
14f9c5c9 2487
d2e4a39e
AS
2488struct type *
2489ada_index_type (struct type *type, int n)
14f9c5c9 2490{
4c4b4cd2
PH
2491 struct type *result_type;
2492
14f9c5c9
AS
2493 type = desc_base_type (type);
2494
2495 if (n > ada_array_arity (type))
2496 return NULL;
2497
4c4b4cd2 2498 if (ada_is_simple_array_type (type))
14f9c5c9
AS
2499 {
2500 int i;
2501
2502 for (i = 1; i < n; i += 1)
4c4b4cd2
PH
2503 type = TYPE_TARGET_TYPE (type);
2504 result_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 0));
2505 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2506 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679
JB
2507 perhaps stabsread.c would make more sense. */
2508 if (result_type == NULL || TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2509 result_type = builtin_type_int;
14f9c5c9 2510
4c4b4cd2 2511 return result_type;
14f9c5c9 2512 }
d2e4a39e 2513 else
14f9c5c9
AS
2514 return desc_index_type (desc_bounds_type (type), n);
2515}
2516
2517/* Given that arr is an array type, returns the lower bound of the
2518 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2
PH
2519 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2520 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2521 bounds type. It works for other arrays with bounds supplied by
2522 run-time quantities other than discriminants. */
14f9c5c9 2523
abb68b3e 2524static LONGEST
d2e4a39e 2525ada_array_bound_from_type (struct type * arr_type, int n, int which,
4c4b4cd2 2526 struct type ** typep)
14f9c5c9 2527{
d2e4a39e
AS
2528 struct type *type;
2529 struct type *index_type_desc;
14f9c5c9
AS
2530
2531 if (ada_is_packed_array_type (arr_type))
2532 arr_type = decode_packed_array_type (arr_type);
2533
4c4b4cd2 2534 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
14f9c5c9
AS
2535 {
2536 if (typep != NULL)
4c4b4cd2 2537 *typep = builtin_type_int;
d2e4a39e 2538 return (LONGEST) - which;
14f9c5c9
AS
2539 }
2540
2541 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2542 type = TYPE_TARGET_TYPE (arr_type);
2543 else
2544 type = arr_type;
2545
2546 index_type_desc = ada_find_parallel_type (type, "___XA");
d2e4a39e 2547 if (index_type_desc == NULL)
14f9c5c9 2548 {
d2e4a39e 2549 struct type *index_type;
14f9c5c9 2550
d2e4a39e 2551 while (n > 1)
4c4b4cd2
PH
2552 {
2553 type = TYPE_TARGET_TYPE (type);
2554 n -= 1;
2555 }
14f9c5c9 2556
abb68b3e 2557 index_type = TYPE_INDEX_TYPE (type);
14f9c5c9 2558 if (typep != NULL)
4c4b4cd2 2559 *typep = index_type;
abb68b3e
JB
2560
2561 /* The index type is either a range type or an enumerated type.
2562 For the range type, we have some macros that allow us to
2563 extract the value of the low and high bounds. But they
2564 do now work for enumerated types. The expressions used
2565 below work for both range and enum types. */
d2e4a39e 2566 return
4c4b4cd2 2567 (LONGEST) (which == 0
abb68b3e
JB
2568 ? TYPE_FIELD_BITPOS (index_type, 0)
2569 : TYPE_FIELD_BITPOS (index_type,
2570 TYPE_NFIELDS (index_type) - 1));
14f9c5c9 2571 }
d2e4a39e 2572 else
14f9c5c9 2573 {
d2e4a39e 2574 struct type *index_type =
4c4b4cd2
PH
2575 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, n - 1),
2576 NULL, TYPE_OBJFILE (arr_type));
abb68b3e 2577
14f9c5c9 2578 if (typep != NULL)
abb68b3e
JB
2579 *typep = index_type;
2580
d2e4a39e 2581 return
4c4b4cd2
PH
2582 (LONGEST) (which == 0
2583 ? TYPE_LOW_BOUND (index_type)
2584 : TYPE_HIGH_BOUND (index_type));
14f9c5c9
AS
2585 }
2586}
2587
2588/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
2589 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2590 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 2591 supplied by run-time quantities other than discriminants. */
14f9c5c9 2592
d2e4a39e 2593struct value *
4dc81987 2594ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 2595{
df407dfe 2596 struct type *arr_type = value_type (arr);
14f9c5c9
AS
2597
2598 if (ada_is_packed_array_type (arr_type))
2599 return ada_array_bound (decode_packed_array (arr), n, which);
4c4b4cd2 2600 else if (ada_is_simple_array_type (arr_type))
14f9c5c9 2601 {
d2e4a39e 2602 struct type *type;
14f9c5c9
AS
2603 LONGEST v = ada_array_bound_from_type (arr_type, n, which, &type);
2604 return value_from_longest (type, v);
2605 }
2606 else
2607 return desc_one_bound (desc_bounds (arr), n, which);
2608}
2609
2610/* Given that arr is an array value, returns the length of the
2611 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
2612 supplied by run-time quantities other than discriminants.
2613 Does not work for arrays indexed by enumeration types with representation
2614 clauses at the moment. */
14f9c5c9 2615
d2e4a39e
AS
2616struct value *
2617ada_array_length (struct value *arr, int n)
14f9c5c9 2618{
df407dfe 2619 struct type *arr_type = ada_check_typedef (value_type (arr));
14f9c5c9
AS
2620
2621 if (ada_is_packed_array_type (arr_type))
2622 return ada_array_length (decode_packed_array (arr), n);
2623
4c4b4cd2 2624 if (ada_is_simple_array_type (arr_type))
14f9c5c9 2625 {
d2e4a39e 2626 struct type *type;
14f9c5c9 2627 LONGEST v =
4c4b4cd2
PH
2628 ada_array_bound_from_type (arr_type, n, 1, &type) -
2629 ada_array_bound_from_type (arr_type, n, 0, NULL) + 1;
14f9c5c9
AS
2630 return value_from_longest (type, v);
2631 }
2632 else
d2e4a39e 2633 return
72d5681a 2634 value_from_longest (builtin_type_int,
4c4b4cd2
PH
2635 value_as_long (desc_one_bound (desc_bounds (arr),
2636 n, 1))
2637 - value_as_long (desc_one_bound (desc_bounds (arr),
2638 n, 0)) + 1);
2639}
2640
2641/* An empty array whose type is that of ARR_TYPE (an array type),
2642 with bounds LOW to LOW-1. */
2643
2644static struct value *
2645empty_array (struct type *arr_type, int low)
2646{
6c038f32 2647 struct type *index_type =
0b5d8877
PH
2648 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type)),
2649 low, low - 1);
2650 struct type *elt_type = ada_array_element_type (arr_type, 1);
2651 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 2652}
14f9c5c9 2653\f
d2e4a39e 2654
4c4b4cd2 2655 /* Name resolution */
14f9c5c9 2656
4c4b4cd2
PH
2657/* The "decoded" name for the user-definable Ada operator corresponding
2658 to OP. */
14f9c5c9 2659
d2e4a39e 2660static const char *
4c4b4cd2 2661ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
2662{
2663 int i;
2664
4c4b4cd2 2665 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
2666 {
2667 if (ada_opname_table[i].op == op)
4c4b4cd2 2668 return ada_opname_table[i].decoded;
14f9c5c9 2669 }
323e0a4a 2670 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
2671}
2672
2673
4c4b4cd2
PH
2674/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2675 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2676 undefined namespace) and converts operators that are
2677 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
2678 non-null, it provides a preferred result type [at the moment, only
2679 type void has any effect---causing procedures to be preferred over
2680 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 2681 return type is preferred. May change (expand) *EXP. */
14f9c5c9 2682
4c4b4cd2
PH
2683static void
2684resolve (struct expression **expp, int void_context_p)
14f9c5c9
AS
2685{
2686 int pc;
2687 pc = 0;
4c4b4cd2 2688 resolve_subexp (expp, &pc, 1, void_context_p ? builtin_type_void : NULL);
14f9c5c9
AS
2689}
2690
4c4b4cd2
PH
2691/* Resolve the operator of the subexpression beginning at
2692 position *POS of *EXPP. "Resolving" consists of replacing
2693 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2694 with their resolutions, replacing built-in operators with
2695 function calls to user-defined operators, where appropriate, and,
2696 when DEPROCEDURE_P is non-zero, converting function-valued variables
2697 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2698 are as in ada_resolve, above. */
14f9c5c9 2699
d2e4a39e 2700static struct value *
4c4b4cd2 2701resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
76a01679 2702 struct type *context_type)
14f9c5c9
AS
2703{
2704 int pc = *pos;
2705 int i;
4c4b4cd2 2706 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 2707 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
2708 struct value **argvec; /* Vector of operand types (alloca'ed). */
2709 int nargs; /* Number of operands. */
52ce6436 2710 int oplen;
14f9c5c9
AS
2711
2712 argvec = NULL;
2713 nargs = 0;
2714 exp = *expp;
2715
52ce6436
PH
2716 /* Pass one: resolve operands, saving their types and updating *pos,
2717 if needed. */
14f9c5c9
AS
2718 switch (op)
2719 {
4c4b4cd2
PH
2720 case OP_FUNCALL:
2721 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
2722 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2723 *pos += 7;
4c4b4cd2
PH
2724 else
2725 {
2726 *pos += 3;
2727 resolve_subexp (expp, pos, 0, NULL);
2728 }
2729 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
2730 break;
2731
14f9c5c9 2732 case UNOP_ADDR:
4c4b4cd2
PH
2733 *pos += 1;
2734 resolve_subexp (expp, pos, 0, NULL);
2735 break;
2736
52ce6436
PH
2737 case UNOP_QUAL:
2738 *pos += 3;
2739 resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
4c4b4cd2
PH
2740 break;
2741
52ce6436 2742 case OP_ATR_MODULUS:
4c4b4cd2
PH
2743 case OP_ATR_SIZE:
2744 case OP_ATR_TAG:
4c4b4cd2
PH
2745 case OP_ATR_FIRST:
2746 case OP_ATR_LAST:
2747 case OP_ATR_LENGTH:
2748 case OP_ATR_POS:
2749 case OP_ATR_VAL:
4c4b4cd2
PH
2750 case OP_ATR_MIN:
2751 case OP_ATR_MAX:
52ce6436
PH
2752 case TERNOP_IN_RANGE:
2753 case BINOP_IN_BOUNDS:
2754 case UNOP_IN_RANGE:
2755 case OP_AGGREGATE:
2756 case OP_OTHERS:
2757 case OP_CHOICES:
2758 case OP_POSITIONAL:
2759 case OP_DISCRETE_RANGE:
2760 case OP_NAME:
2761 ada_forward_operator_length (exp, pc, &oplen, &nargs);
2762 *pos += oplen;
14f9c5c9
AS
2763 break;
2764
2765 case BINOP_ASSIGN:
2766 {
4c4b4cd2
PH
2767 struct value *arg1;
2768
2769 *pos += 1;
2770 arg1 = resolve_subexp (expp, pos, 0, NULL);
2771 if (arg1 == NULL)
2772 resolve_subexp (expp, pos, 1, NULL);
2773 else
df407dfe 2774 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 2775 break;
14f9c5c9
AS
2776 }
2777
4c4b4cd2 2778 case UNOP_CAST:
4c4b4cd2
PH
2779 *pos += 3;
2780 nargs = 1;
2781 break;
14f9c5c9 2782
4c4b4cd2
PH
2783 case BINOP_ADD:
2784 case BINOP_SUB:
2785 case BINOP_MUL:
2786 case BINOP_DIV:
2787 case BINOP_REM:
2788 case BINOP_MOD:
2789 case BINOP_EXP:
2790 case BINOP_CONCAT:
2791 case BINOP_LOGICAL_AND:
2792 case BINOP_LOGICAL_OR:
2793 case BINOP_BITWISE_AND:
2794 case BINOP_BITWISE_IOR:
2795 case BINOP_BITWISE_XOR:
14f9c5c9 2796
4c4b4cd2
PH
2797 case BINOP_EQUAL:
2798 case BINOP_NOTEQUAL:
2799 case BINOP_LESS:
2800 case BINOP_GTR:
2801 case BINOP_LEQ:
2802 case BINOP_GEQ:
14f9c5c9 2803
4c4b4cd2
PH
2804 case BINOP_REPEAT:
2805 case BINOP_SUBSCRIPT:
2806 case BINOP_COMMA:
40c8aaa9
JB
2807 *pos += 1;
2808 nargs = 2;
2809 break;
14f9c5c9 2810
4c4b4cd2
PH
2811 case UNOP_NEG:
2812 case UNOP_PLUS:
2813 case UNOP_LOGICAL_NOT:
2814 case UNOP_ABS:
2815 case UNOP_IND:
2816 *pos += 1;
2817 nargs = 1;
2818 break;
14f9c5c9 2819
4c4b4cd2
PH
2820 case OP_LONG:
2821 case OP_DOUBLE:
2822 case OP_VAR_VALUE:
2823 *pos += 4;
2824 break;
14f9c5c9 2825
4c4b4cd2
PH
2826 case OP_TYPE:
2827 case OP_BOOL:
2828 case OP_LAST:
4c4b4cd2
PH
2829 case OP_INTERNALVAR:
2830 *pos += 3;
2831 break;
14f9c5c9 2832
4c4b4cd2
PH
2833 case UNOP_MEMVAL:
2834 *pos += 3;
2835 nargs = 1;
2836 break;
2837
67f3407f
DJ
2838 case OP_REGISTER:
2839 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2840 break;
2841
4c4b4cd2
PH
2842 case STRUCTOP_STRUCT:
2843 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2844 nargs = 1;
2845 break;
2846
4c4b4cd2 2847 case TERNOP_SLICE:
4c4b4cd2
PH
2848 *pos += 1;
2849 nargs = 3;
2850 break;
2851
52ce6436 2852 case OP_STRING:
14f9c5c9 2853 break;
4c4b4cd2
PH
2854
2855 default:
323e0a4a 2856 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
2857 }
2858
76a01679 2859 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
4c4b4cd2
PH
2860 for (i = 0; i < nargs; i += 1)
2861 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
2862 argvec[i] = NULL;
2863 exp = *expp;
2864
2865 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
2866 switch (op)
2867 {
2868 default:
2869 break;
2870
14f9c5c9 2871 case OP_VAR_VALUE:
4c4b4cd2 2872 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
2873 {
2874 struct ada_symbol_info *candidates;
2875 int n_candidates;
2876
2877 n_candidates =
2878 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2879 (exp->elts[pc + 2].symbol),
2880 exp->elts[pc + 1].block, VAR_DOMAIN,
2881 &candidates);
2882
2883 if (n_candidates > 1)
2884 {
2885 /* Types tend to get re-introduced locally, so if there
2886 are any local symbols that are not types, first filter
2887 out all types. */
2888 int j;
2889 for (j = 0; j < n_candidates; j += 1)
2890 switch (SYMBOL_CLASS (candidates[j].sym))
2891 {
2892 case LOC_REGISTER:
2893 case LOC_ARG:
2894 case LOC_REF_ARG:
76a01679
JB
2895 case LOC_REGPARM_ADDR:
2896 case LOC_LOCAL:
76a01679 2897 case LOC_COMPUTED:
76a01679
JB
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:
96d887e8
PH
4318 case LOC_REGPARM_ADDR:
4319 case LOC_LOCAL:
4320 case LOC_TYPEDEF:
96d887e8 4321 case LOC_COMPUTED:
76a01679
JB
4322 for (j = FIRST_LOCAL_BLOCK;
4323 j < BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s)); j += 1)
4324 {
4325 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), j);
4326 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4327 return s;
4328 }
4329 break;
96d887e8
PH
4330 default:
4331 break;
4332 }
4333 }
4334 return NULL;
4c4b4cd2
PH
4335}
4336
96d887e8
PH
4337/* Return a minimal symbol matching NAME according to Ada decoding
4338 rules. Returns NULL if there is no such minimal symbol. Names
4339 prefixed with "standard__" are handled specially: "standard__" is
4340 first stripped off, and only static and global symbols are searched. */
4c4b4cd2 4341
96d887e8
PH
4342struct minimal_symbol *
4343ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4344{
4c4b4cd2 4345 struct objfile *objfile;
96d887e8
PH
4346 struct minimal_symbol *msymbol;
4347 int wild_match;
4c4b4cd2 4348
96d887e8 4349 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
4c4b4cd2 4350 {
96d887e8 4351 name += sizeof ("standard__") - 1;
4c4b4cd2 4352 wild_match = 0;
4c4b4cd2
PH
4353 }
4354 else
96d887e8 4355 wild_match = (strstr (name, "__") == NULL);
4c4b4cd2 4356
96d887e8
PH
4357 ALL_MSYMBOLS (objfile, msymbol)
4358 {
4359 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match)
4360 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4361 return msymbol;
4362 }
4c4b4cd2 4363
96d887e8
PH
4364 return NULL;
4365}
4c4b4cd2 4366
96d887e8
PH
4367/* For all subprograms that statically enclose the subprogram of the
4368 selected frame, add symbols matching identifier NAME in DOMAIN
4369 and their blocks to the list of data in OBSTACKP, as for
4370 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4371 wildcard prefix. */
4c4b4cd2 4372
96d887e8
PH
4373static void
4374add_symbols_from_enclosing_procs (struct obstack *obstackp,
76a01679 4375 const char *name, domain_enum namespace,
96d887e8
PH
4376 int wild_match)
4377{
96d887e8 4378}
14f9c5c9 4379
96d887e8
PH
4380/* True if TYPE is definitely an artificial type supplied to a symbol
4381 for which no debugging information was given in the symbol file. */
14f9c5c9 4382
96d887e8
PH
4383static int
4384is_nondebugging_type (struct type *type)
4385{
4386 char *name = ada_type_name (type);
4387 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4388}
4c4b4cd2 4389
96d887e8
PH
4390/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4391 duplicate other symbols in the list (The only case I know of where
4392 this happens is when object files containing stabs-in-ecoff are
4393 linked with files containing ordinary ecoff debugging symbols (or no
4394 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4395 Returns the number of items in the modified list. */
4c4b4cd2 4396
96d887e8
PH
4397static int
4398remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4399{
4400 int i, j;
4c4b4cd2 4401
96d887e8
PH
4402 i = 0;
4403 while (i < nsyms)
4404 {
4405 if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
4406 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4407 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4408 {
4409 for (j = 0; j < nsyms; j += 1)
4410 {
4411 if (i != j
4412 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4413 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
76a01679 4414 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
96d887e8
PH
4415 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4416 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4417 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
4c4b4cd2 4418 {
96d887e8
PH
4419 int k;
4420 for (k = i + 1; k < nsyms; k += 1)
76a01679 4421 syms[k - 1] = syms[k];
96d887e8
PH
4422 nsyms -= 1;
4423 goto NextSymbol;
4c4b4cd2 4424 }
4c4b4cd2 4425 }
4c4b4cd2 4426 }
96d887e8
PH
4427 i += 1;
4428 NextSymbol:
4429 ;
14f9c5c9 4430 }
96d887e8 4431 return nsyms;
14f9c5c9
AS
4432}
4433
96d887e8
PH
4434/* Given a type that corresponds to a renaming entity, use the type name
4435 to extract the scope (package name or function name, fully qualified,
4436 and following the GNAT encoding convention) where this renaming has been
4437 defined. The string returned needs to be deallocated after use. */
4c4b4cd2 4438
96d887e8
PH
4439static char *
4440xget_renaming_scope (struct type *renaming_type)
14f9c5c9 4441{
96d887e8
PH
4442 /* The renaming types adhere to the following convention:
4443 <scope>__<rename>___<XR extension>.
4444 So, to extract the scope, we search for the "___XR" extension,
4445 and then backtrack until we find the first "__". */
76a01679 4446
96d887e8
PH
4447 const char *name = type_name_no_tag (renaming_type);
4448 char *suffix = strstr (name, "___XR");
4449 char *last;
4450 int scope_len;
4451 char *scope;
14f9c5c9 4452
96d887e8
PH
4453 /* Now, backtrack a bit until we find the first "__". Start looking
4454 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 4455
96d887e8
PH
4456 for (last = suffix - 3; last > name; last--)
4457 if (last[0] == '_' && last[1] == '_')
4458 break;
76a01679 4459
96d887e8 4460 /* Make a copy of scope and return it. */
14f9c5c9 4461
96d887e8
PH
4462 scope_len = last - name;
4463 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
14f9c5c9 4464
96d887e8
PH
4465 strncpy (scope, name, scope_len);
4466 scope[scope_len] = '\0';
4c4b4cd2 4467
96d887e8 4468 return scope;
4c4b4cd2
PH
4469}
4470
96d887e8 4471/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 4472
96d887e8
PH
4473static int
4474is_package_name (const char *name)
4c4b4cd2 4475{
96d887e8
PH
4476 /* Here, We take advantage of the fact that no symbols are generated
4477 for packages, while symbols are generated for each function.
4478 So the condition for NAME represent a package becomes equivalent
4479 to NAME not existing in our list of symbols. There is only one
4480 small complication with library-level functions (see below). */
4c4b4cd2 4481
96d887e8 4482 char *fun_name;
76a01679 4483
96d887e8
PH
4484 /* If it is a function that has not been defined at library level,
4485 then we should be able to look it up in the symbols. */
4486 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4487 return 0;
14f9c5c9 4488
96d887e8
PH
4489 /* Library-level function names start with "_ada_". See if function
4490 "_ada_" followed by NAME can be found. */
14f9c5c9 4491
96d887e8 4492 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 4493 functions names cannot contain "__" in them. */
96d887e8
PH
4494 if (strstr (name, "__") != NULL)
4495 return 0;
4c4b4cd2 4496
b435e160 4497 fun_name = xstrprintf ("_ada_%s", name);
14f9c5c9 4498
96d887e8
PH
4499 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4500}
14f9c5c9 4501
96d887e8 4502/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 4503 not visible from FUNCTION_NAME. */
14f9c5c9 4504
96d887e8 4505static int
aeb5907d 4506old_renaming_is_invisible (const struct symbol *sym, char *function_name)
96d887e8 4507{
aeb5907d
JB
4508 char *scope;
4509
4510 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4511 return 0;
4512
4513 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
d2e4a39e 4514
96d887e8 4515 make_cleanup (xfree, scope);
14f9c5c9 4516
96d887e8
PH
4517 /* If the rename has been defined in a package, then it is visible. */
4518 if (is_package_name (scope))
aeb5907d 4519 return 0;
14f9c5c9 4520
96d887e8
PH
4521 /* Check that the rename is in the current function scope by checking
4522 that its name starts with SCOPE. */
76a01679 4523
96d887e8
PH
4524 /* If the function name starts with "_ada_", it means that it is
4525 a library-level function. Strip this prefix before doing the
4526 comparison, as the encoding for the renaming does not contain
4527 this prefix. */
4528 if (strncmp (function_name, "_ada_", 5) == 0)
4529 function_name += 5;
f26caa11 4530
aeb5907d 4531 return (strncmp (function_name, scope, strlen (scope)) != 0);
f26caa11
PH
4532}
4533
aeb5907d
JB
4534/* Remove entries from SYMS that corresponds to a renaming entity that
4535 is not visible from the function associated with CURRENT_BLOCK or
4536 that is superfluous due to the presence of more specific renaming
4537 information. Places surviving symbols in the initial entries of
4538 SYMS and returns the number of surviving symbols.
96d887e8
PH
4539
4540 Rationale:
aeb5907d
JB
4541 First, in cases where an object renaming is implemented as a
4542 reference variable, GNAT may produce both the actual reference
4543 variable and the renaming encoding. In this case, we discard the
4544 latter.
4545
4546 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
4547 entity. Unfortunately, STABS currently does not support the definition
4548 of types that are local to a given lexical block, so all renamings types
4549 are emitted at library level. As a consequence, if an application
4550 contains two renaming entities using the same name, and a user tries to
4551 print the value of one of these entities, the result of the ada symbol
4552 lookup will also contain the wrong renaming type.
f26caa11 4553
96d887e8
PH
4554 This function partially covers for this limitation by attempting to
4555 remove from the SYMS list renaming symbols that should be visible
4556 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4557 method with the current information available. The implementation
4558 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4559
4560 - When the user tries to print a rename in a function while there
4561 is another rename entity defined in a package: Normally, the
4562 rename in the function has precedence over the rename in the
4563 package, so the latter should be removed from the list. This is
4564 currently not the case.
4565
4566 - This function will incorrectly remove valid renames if
4567 the CURRENT_BLOCK corresponds to a function which symbol name
4568 has been changed by an "Export" pragma. As a consequence,
4569 the user will be unable to print such rename entities. */
4c4b4cd2 4570
14f9c5c9 4571static int
aeb5907d
JB
4572remove_irrelevant_renamings (struct ada_symbol_info *syms,
4573 int nsyms, const struct block *current_block)
4c4b4cd2
PH
4574{
4575 struct symbol *current_function;
4576 char *current_function_name;
4577 int i;
aeb5907d
JB
4578 int is_new_style_renaming;
4579
4580 /* If there is both a renaming foo___XR... encoded as a variable and
4581 a simple variable foo in the same block, discard the latter.
4582 First, zero out such symbols, then compress. */
4583 is_new_style_renaming = 0;
4584 for (i = 0; i < nsyms; i += 1)
4585 {
4586 struct symbol *sym = syms[i].sym;
4587 struct block *block = syms[i].block;
4588 const char *name;
4589 const char *suffix;
4590
4591 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4592 continue;
4593 name = SYMBOL_LINKAGE_NAME (sym);
4594 suffix = strstr (name, "___XR");
4595
4596 if (suffix != NULL)
4597 {
4598 int name_len = suffix - name;
4599 int j;
4600 is_new_style_renaming = 1;
4601 for (j = 0; j < nsyms; j += 1)
4602 if (i != j && syms[j].sym != NULL
4603 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
4604 name_len) == 0
4605 && block == syms[j].block)
4606 syms[j].sym = NULL;
4607 }
4608 }
4609 if (is_new_style_renaming)
4610 {
4611 int j, k;
4612
4613 for (j = k = 0; j < nsyms; j += 1)
4614 if (syms[j].sym != NULL)
4615 {
4616 syms[k] = syms[j];
4617 k += 1;
4618 }
4619 return k;
4620 }
4c4b4cd2
PH
4621
4622 /* Extract the function name associated to CURRENT_BLOCK.
4623 Abort if unable to do so. */
76a01679 4624
4c4b4cd2
PH
4625 if (current_block == NULL)
4626 return nsyms;
76a01679 4627
7f0df278 4628 current_function = block_linkage_function (current_block);
4c4b4cd2
PH
4629 if (current_function == NULL)
4630 return nsyms;
4631
4632 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
4633 if (current_function_name == NULL)
4634 return nsyms;
4635
4636 /* Check each of the symbols, and remove it from the list if it is
4637 a type corresponding to a renaming that is out of the scope of
4638 the current block. */
4639
4640 i = 0;
4641 while (i < nsyms)
4642 {
aeb5907d
JB
4643 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
4644 == ADA_OBJECT_RENAMING
4645 && old_renaming_is_invisible (syms[i].sym, current_function_name))
4c4b4cd2
PH
4646 {
4647 int j;
aeb5907d 4648 for (j = i + 1; j < nsyms; j += 1)
76a01679 4649 syms[j - 1] = syms[j];
4c4b4cd2
PH
4650 nsyms -= 1;
4651 }
4652 else
4653 i += 1;
4654 }
4655
4656 return nsyms;
4657}
4658
4659/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4660 scope and in global scopes, returning the number of matches. Sets
6c9353d3 4661 *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4c4b4cd2
PH
4662 indicating the symbols found and the blocks and symbol tables (if
4663 any) in which they were found. This vector are transient---good only to
4664 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4665 symbol match within the nest of blocks whose innermost member is BLOCK0,
4666 is the one match returned (no other matches in that or
4667 enclosing blocks is returned). If there are any matches in or
4668 surrounding BLOCK0, then these alone are returned. Otherwise, the
4669 search extends to global and file-scope (static) symbol tables.
4670 Names prefixed with "standard__" are handled specially: "standard__"
4671 is first stripped off, and only static and global symbols are searched. */
14f9c5c9
AS
4672
4673int
4c4b4cd2 4674ada_lookup_symbol_list (const char *name0, const struct block *block0,
76a01679
JB
4675 domain_enum namespace,
4676 struct ada_symbol_info **results)
14f9c5c9
AS
4677{
4678 struct symbol *sym;
4679 struct symtab *s;
4680 struct partial_symtab *ps;
4681 struct blockvector *bv;
4682 struct objfile *objfile;
14f9c5c9 4683 struct block *block;
4c4b4cd2 4684 const char *name;
14f9c5c9 4685 struct minimal_symbol *msymbol;
4c4b4cd2 4686 int wild_match;
14f9c5c9 4687 int cacheIfUnique;
4c4b4cd2
PH
4688 int block_depth;
4689 int ndefns;
14f9c5c9 4690
4c4b4cd2
PH
4691 obstack_free (&symbol_list_obstack, NULL);
4692 obstack_init (&symbol_list_obstack);
14f9c5c9 4693
14f9c5c9
AS
4694 cacheIfUnique = 0;
4695
4696 /* Search specified block and its superiors. */
4697
4c4b4cd2
PH
4698 wild_match = (strstr (name0, "__") == NULL);
4699 name = name0;
76a01679
JB
4700 block = (struct block *) block0; /* FIXME: No cast ought to be
4701 needed, but adding const will
4702 have a cascade effect. */
4c4b4cd2
PH
4703 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
4704 {
4705 wild_match = 0;
4706 block = NULL;
4707 name = name0 + sizeof ("standard__") - 1;
4708 }
4709
4710 block_depth = 0;
14f9c5c9
AS
4711 while (block != NULL)
4712 {
4c4b4cd2 4713 block_depth += 1;
76a01679 4714 ada_add_block_symbols (&symbol_list_obstack, block, name,
2570f2b7 4715 namespace, NULL, wild_match);
14f9c5c9 4716
4c4b4cd2
PH
4717 /* If we found a non-function match, assume that's the one. */
4718 if (is_nonfunction (defns_collected (&symbol_list_obstack, 0),
76a01679 4719 num_defns_collected (&symbol_list_obstack)))
4c4b4cd2 4720 goto done;
14f9c5c9
AS
4721
4722 block = BLOCK_SUPERBLOCK (block);
4723 }
4724
4c4b4cd2
PH
4725 /* If no luck so far, try to find NAME as a local symbol in some lexically
4726 enclosing subprogram. */
4727 if (num_defns_collected (&symbol_list_obstack) == 0 && block_depth > 2)
4728 add_symbols_from_enclosing_procs (&symbol_list_obstack,
76a01679 4729 name, namespace, wild_match);
4c4b4cd2
PH
4730
4731 /* If we found ANY matches among non-global symbols, we're done. */
14f9c5c9 4732
4c4b4cd2 4733 if (num_defns_collected (&symbol_list_obstack) > 0)
14f9c5c9 4734 goto done;
d2e4a39e 4735
14f9c5c9 4736 cacheIfUnique = 1;
2570f2b7 4737 if (lookup_cached_symbol (name0, namespace, &sym, &block))
4c4b4cd2
PH
4738 {
4739 if (sym != NULL)
2570f2b7 4740 add_defn_to_vec (&symbol_list_obstack, sym, block);
4c4b4cd2
PH
4741 goto done;
4742 }
14f9c5c9
AS
4743
4744 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4c4b4cd2 4745 tables, and psymtab's. */
14f9c5c9 4746
11309657 4747 ALL_PRIMARY_SYMTABS (objfile, s)
d2e4a39e
AS
4748 {
4749 QUIT;
d2e4a39e
AS
4750 bv = BLOCKVECTOR (s);
4751 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
76a01679 4752 ada_add_block_symbols (&symbol_list_obstack, block, name, namespace,
2570f2b7 4753 objfile, wild_match);
d2e4a39e 4754 }
14f9c5c9 4755
4c4b4cd2 4756 if (namespace == VAR_DOMAIN)
14f9c5c9
AS
4757 {
4758 ALL_MSYMBOLS (objfile, msymbol)
d2e4a39e 4759 {
4c4b4cd2
PH
4760 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match))
4761 {
4762 switch (MSYMBOL_TYPE (msymbol))
4763 {
4764 case mst_solib_trampoline:
4765 break;
4766 default:
4767 s = find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol));
4768 if (s != NULL)
4769 {
4770 int ndefns0 = num_defns_collected (&symbol_list_obstack);
4771 QUIT;
4772 bv = BLOCKVECTOR (s);
4773 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
4774 ada_add_block_symbols (&symbol_list_obstack, block,
4775 SYMBOL_LINKAGE_NAME (msymbol),
2570f2b7 4776 namespace, objfile, wild_match);
76a01679 4777
4c4b4cd2
PH
4778 if (num_defns_collected (&symbol_list_obstack) == ndefns0)
4779 {
4780 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
4781 ada_add_block_symbols (&symbol_list_obstack, block,
4782 SYMBOL_LINKAGE_NAME (msymbol),
2570f2b7 4783 namespace, objfile,
4c4b4cd2
PH
4784 wild_match);
4785 }
4786 }
4787 }
4788 }
d2e4a39e 4789 }
14f9c5c9 4790 }
d2e4a39e 4791
14f9c5c9 4792 ALL_PSYMTABS (objfile, ps)
d2e4a39e
AS
4793 {
4794 QUIT;
4795 if (!ps->readin
4c4b4cd2 4796 && ada_lookup_partial_symbol (ps, name, 1, namespace, wild_match))
d2e4a39e 4797 {
4c4b4cd2
PH
4798 s = PSYMTAB_TO_SYMTAB (ps);
4799 if (!s->primary)
4800 continue;
4801 bv = BLOCKVECTOR (s);
4802 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
4803 ada_add_block_symbols (&symbol_list_obstack, block, name,
2570f2b7 4804 namespace, objfile, wild_match);
d2e4a39e
AS
4805 }
4806 }
4807
4c4b4cd2 4808 /* Now add symbols from all per-file blocks if we've gotten no hits
14f9c5c9 4809 (Not strictly correct, but perhaps better than an error).
4c4b4cd2 4810 Do the symtabs first, then check the psymtabs. */
d2e4a39e 4811
4c4b4cd2 4812 if (num_defns_collected (&symbol_list_obstack) == 0)
14f9c5c9
AS
4813 {
4814
11309657 4815 ALL_PRIMARY_SYMTABS (objfile, s)
d2e4a39e 4816 {
4c4b4cd2 4817 QUIT;
4c4b4cd2
PH
4818 bv = BLOCKVECTOR (s);
4819 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
76a01679 4820 ada_add_block_symbols (&symbol_list_obstack, block, name, namespace,
2570f2b7 4821 objfile, wild_match);
d2e4a39e
AS
4822 }
4823
14f9c5c9 4824 ALL_PSYMTABS (objfile, ps)
d2e4a39e 4825 {
4c4b4cd2
PH
4826 QUIT;
4827 if (!ps->readin
4828 && ada_lookup_partial_symbol (ps, name, 0, namespace, wild_match))
4829 {
4830 s = PSYMTAB_TO_SYMTAB (ps);
4831 bv = BLOCKVECTOR (s);
4832 if (!s->primary)
4833 continue;
4834 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
76a01679 4835 ada_add_block_symbols (&symbol_list_obstack, block, name,
2570f2b7 4836 namespace, objfile, wild_match);
4c4b4cd2 4837 }
d2e4a39e
AS
4838 }
4839 }
14f9c5c9 4840
4c4b4cd2
PH
4841done:
4842 ndefns = num_defns_collected (&symbol_list_obstack);
4843 *results = defns_collected (&symbol_list_obstack, 1);
4844
4845 ndefns = remove_extra_symbols (*results, ndefns);
4846
d2e4a39e 4847 if (ndefns == 0)
2570f2b7 4848 cache_symbol (name0, namespace, NULL, NULL);
14f9c5c9 4849
4c4b4cd2 4850 if (ndefns == 1 && cacheIfUnique)
2570f2b7 4851 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
14f9c5c9 4852
aeb5907d 4853 ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
14f9c5c9 4854
14f9c5c9
AS
4855 return ndefns;
4856}
4857
d2e4a39e 4858struct symbol *
aeb5907d 4859ada_lookup_encoded_symbol (const char *name, const struct block *block0,
21b556f4 4860 domain_enum namespace, struct block **block_found)
14f9c5c9 4861{
4c4b4cd2 4862 struct ada_symbol_info *candidates;
14f9c5c9
AS
4863 int n_candidates;
4864
aeb5907d 4865 n_candidates = ada_lookup_symbol_list (name, block0, namespace, &candidates);
14f9c5c9
AS
4866
4867 if (n_candidates == 0)
4868 return NULL;
4c4b4cd2 4869
aeb5907d
JB
4870 if (block_found != NULL)
4871 *block_found = candidates[0].block;
4c4b4cd2 4872
21b556f4 4873 return fixup_symbol_section (candidates[0].sym, NULL);
aeb5907d
JB
4874}
4875
4876/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4877 scope and in global scopes, or NULL if none. NAME is folded and
4878 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4879 choosing the first symbol if there are multiple choices.
4880 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4881 table in which the symbol was found (in both cases, these
4882 assignments occur only if the pointers are non-null). */
4883struct symbol *
4884ada_lookup_symbol (const char *name, const struct block *block0,
21b556f4 4885 domain_enum namespace, int *is_a_field_of_this)
aeb5907d
JB
4886{
4887 if (is_a_field_of_this != NULL)
4888 *is_a_field_of_this = 0;
4889
4890 return
4891 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
21b556f4 4892 block0, namespace, NULL);
4c4b4cd2 4893}
14f9c5c9 4894
4c4b4cd2
PH
4895static struct symbol *
4896ada_lookup_symbol_nonlocal (const char *name,
76a01679
JB
4897 const char *linkage_name,
4898 const struct block *block,
21b556f4 4899 const domain_enum domain)
4c4b4cd2
PH
4900{
4901 if (linkage_name == NULL)
4902 linkage_name = name;
76a01679 4903 return ada_lookup_symbol (linkage_name, block_static_block (block), domain,
21b556f4 4904 NULL);
14f9c5c9
AS
4905}
4906
4907
4c4b4cd2
PH
4908/* True iff STR is a possible encoded suffix of a normal Ada name
4909 that is to be ignored for matching purposes. Suffixes of parallel
4910 names (e.g., XVE) are not included here. Currently, the possible suffixes
4911 are given by either of the regular expression:
4912
babe1480
JB
4913 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
4914 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4915 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 4916 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
4917
4918 Also, any leading "__[0-9]+" sequence is skipped before the suffix
4919 match is performed. This sequence is used to differentiate homonyms,
4920 is an optional part of a valid name suffix. */
4c4b4cd2 4921
14f9c5c9 4922static int
d2e4a39e 4923is_name_suffix (const char *str)
14f9c5c9
AS
4924{
4925 int k;
4c4b4cd2
PH
4926 const char *matching;
4927 const int len = strlen (str);
4928
babe1480
JB
4929 /* Skip optional leading __[0-9]+. */
4930
4c4b4cd2
PH
4931 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
4932 {
babe1480
JB
4933 str += 3;
4934 while (isdigit (str[0]))
4935 str += 1;
4c4b4cd2 4936 }
babe1480
JB
4937
4938 /* [.$][0-9]+ */
4c4b4cd2 4939
babe1480 4940 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 4941 {
babe1480 4942 matching = str + 1;
4c4b4cd2
PH
4943 while (isdigit (matching[0]))
4944 matching += 1;
4945 if (matching[0] == '\0')
4946 return 1;
4947 }
4948
4949 /* ___[0-9]+ */
babe1480 4950
4c4b4cd2
PH
4951 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
4952 {
4953 matching = str + 3;
4954 while (isdigit (matching[0]))
4955 matching += 1;
4956 if (matching[0] == '\0')
4957 return 1;
4958 }
4959
529cad9c
PH
4960#if 0
4961 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4962 with a N at the end. Unfortunately, the compiler uses the same
4963 convention for other internal types it creates. So treating
4964 all entity names that end with an "N" as a name suffix causes
4965 some regressions. For instance, consider the case of an enumerated
4966 type. To support the 'Image attribute, it creates an array whose
4967 name ends with N.
4968 Having a single character like this as a suffix carrying some
4969 information is a bit risky. Perhaps we should change the encoding
4970 to be something like "_N" instead. In the meantime, do not do
4971 the following check. */
4972 /* Protected Object Subprograms */
4973 if (len == 1 && str [0] == 'N')
4974 return 1;
4975#endif
4976
4977 /* _E[0-9]+[bs]$ */
4978 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
4979 {
4980 matching = str + 3;
4981 while (isdigit (matching[0]))
4982 matching += 1;
4983 if ((matching[0] == 'b' || matching[0] == 's')
4984 && matching [1] == '\0')
4985 return 1;
4986 }
4987
4c4b4cd2
PH
4988 /* ??? We should not modify STR directly, as we are doing below. This
4989 is fine in this case, but may become problematic later if we find
4990 that this alternative did not work, and want to try matching
4991 another one from the begining of STR. Since we modified it, we
4992 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
4993 if (str[0] == 'X')
4994 {
4995 str += 1;
d2e4a39e 4996 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
4997 {
4998 if (str[0] != 'n' && str[0] != 'b')
4999 return 0;
5000 str += 1;
5001 }
14f9c5c9 5002 }
babe1480 5003
14f9c5c9
AS
5004 if (str[0] == '\000')
5005 return 1;
babe1480 5006
d2e4a39e 5007 if (str[0] == '_')
14f9c5c9
AS
5008 {
5009 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 5010 return 0;
d2e4a39e 5011 if (str[2] == '_')
4c4b4cd2 5012 {
61ee279c
PH
5013 if (strcmp (str + 3, "JM") == 0)
5014 return 1;
5015 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5016 the LJM suffix in favor of the JM one. But we will
5017 still accept LJM as a valid suffix for a reasonable
5018 amount of time, just to allow ourselves to debug programs
5019 compiled using an older version of GNAT. */
4c4b4cd2
PH
5020 if (strcmp (str + 3, "LJM") == 0)
5021 return 1;
5022 if (str[3] != 'X')
5023 return 0;
1265e4aa
JB
5024 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5025 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
5026 return 1;
5027 if (str[4] == 'R' && str[5] != 'T')
5028 return 1;
5029 return 0;
5030 }
5031 if (!isdigit (str[2]))
5032 return 0;
5033 for (k = 3; str[k] != '\0'; k += 1)
5034 if (!isdigit (str[k]) && str[k] != '_')
5035 return 0;
14f9c5c9
AS
5036 return 1;
5037 }
4c4b4cd2 5038 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 5039 {
4c4b4cd2
PH
5040 for (k = 2; str[k] != '\0'; k += 1)
5041 if (!isdigit (str[k]) && str[k] != '_')
5042 return 0;
14f9c5c9
AS
5043 return 1;
5044 }
5045 return 0;
5046}
d2e4a39e 5047
4c4b4cd2
PH
5048/* Return nonzero if the given string starts with a dot ('.')
5049 followed by zero or more digits.
5050
5051 Note: brobecker/2003-11-10: A forward declaration has not been
5052 added at the begining of this file yet, because this function
5053 is only used to work around a problem found during wild matching
5054 when trying to match minimal symbol names against symbol names
5055 obtained from dwarf-2 data. This function is therefore currently
5056 only used in wild_match() and is likely to be deleted when the
5057 problem in dwarf-2 is fixed. */
5058
5059static int
5060is_dot_digits_suffix (const char *str)
5061{
5062 if (str[0] != '.')
5063 return 0;
5064
5065 str++;
5066 while (isdigit (str[0]))
5067 str++;
5068 return (str[0] == '\0');
5069}
5070
aeb5907d
JB
5071/* Return non-zero if the string starting at NAME and ending before
5072 NAME_END contains no capital letters. */
529cad9c
PH
5073
5074static int
5075is_valid_name_for_wild_match (const char *name0)
5076{
5077 const char *decoded_name = ada_decode (name0);
5078 int i;
5079
5080 for (i=0; decoded_name[i] != '\0'; i++)
5081 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5082 return 0;
5083
5084 return 1;
5085}
5086
4c4b4cd2
PH
5087/* True if NAME represents a name of the form A1.A2....An, n>=1 and
5088 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
5089 informational suffixes of NAME (i.e., for which is_name_suffix is
5090 true). */
5091
14f9c5c9 5092static int
4c4b4cd2 5093wild_match (const char *patn0, int patn_len, const char *name0)
14f9c5c9
AS
5094{
5095 int name_len;
4c4b4cd2 5096 char *name;
aeb5907d 5097 char *name_start;
4c4b4cd2
PH
5098 char *patn;
5099
5100 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
5101 stored in the symbol table for nested function names is sometimes
5102 different from the name of the associated entity stored in
5103 the dwarf-2 data: This is the case for nested subprograms, where
5104 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
5105 while the symbol name from the dwarf-2 data does not.
5106
5107 Although the DWARF-2 standard documents that entity names stored
5108 in the dwarf-2 data should be identical to the name as seen in
5109 the source code, GNAT takes a different approach as we already use
5110 a special encoding mechanism to convey the information so that
5111 a C debugger can still use the information generated to debug
5112 Ada programs. A corollary is that the symbol names in the dwarf-2
5113 data should match the names found in the symbol table. I therefore
5114 consider this issue as a compiler defect.
76a01679 5115
4c4b4cd2
PH
5116 Until the compiler is properly fixed, we work-around the problem
5117 by ignoring such suffixes during the match. We do so by making
5118 a copy of PATN0 and NAME0, and then by stripping such a suffix
5119 if present. We then perform the match on the resulting strings. */
5120 {
5121 char *dot;
5122 name_len = strlen (name0);
5123
aeb5907d 5124 name = name_start = (char *) alloca ((name_len + 1) * sizeof (char));
4c4b4cd2
PH
5125 strcpy (name, name0);
5126 dot = strrchr (name, '.');
5127 if (dot != NULL && is_dot_digits_suffix (dot))
5128 *dot = '\0';
5129
5130 patn = (char *) alloca ((patn_len + 1) * sizeof (char));
5131 strncpy (patn, patn0, patn_len);
5132 patn[patn_len] = '\0';
5133 dot = strrchr (patn, '.');
5134 if (dot != NULL && is_dot_digits_suffix (dot))
5135 {
5136 *dot = '\0';
5137 patn_len = dot - patn;
5138 }
5139 }
5140
5141 /* Now perform the wild match. */
14f9c5c9
AS
5142
5143 name_len = strlen (name);
4c4b4cd2
PH
5144 if (name_len >= patn_len + 5 && strncmp (name, "_ada_", 5) == 0
5145 && strncmp (patn, name + 5, patn_len) == 0
d2e4a39e 5146 && is_name_suffix (name + patn_len + 5))
14f9c5c9
AS
5147 return 1;
5148
d2e4a39e 5149 while (name_len >= patn_len)
14f9c5c9 5150 {
4c4b4cd2
PH
5151 if (strncmp (patn, name, patn_len) == 0
5152 && is_name_suffix (name + patn_len))
aeb5907d 5153 return (name == name_start || is_valid_name_for_wild_match (name0));
4c4b4cd2
PH
5154 do
5155 {
5156 name += 1;
5157 name_len -= 1;
5158 }
d2e4a39e 5159 while (name_len > 0
4c4b4cd2 5160 && name[0] != '.' && (name[0] != '_' || name[1] != '_'));
14f9c5c9 5161 if (name_len <= 0)
4c4b4cd2 5162 return 0;
14f9c5c9 5163 if (name[0] == '_')
4c4b4cd2
PH
5164 {
5165 if (!islower (name[2]))
5166 return 0;
5167 name += 2;
5168 name_len -= 2;
5169 }
14f9c5c9 5170 else
4c4b4cd2
PH
5171 {
5172 if (!islower (name[1]))
5173 return 0;
5174 name += 1;
5175 name_len -= 1;
5176 }
96d887e8
PH
5177 }
5178
5179 return 0;
5180}
5181
5182
5183/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5184 vector *defn_symbols, updating the list of symbols in OBSTACKP
5185 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5186 OBJFILE is the section containing BLOCK.
5187 SYMTAB is recorded with each symbol added. */
5188
5189static void
5190ada_add_block_symbols (struct obstack *obstackp,
76a01679 5191 struct block *block, const char *name,
96d887e8 5192 domain_enum domain, struct objfile *objfile,
2570f2b7 5193 int wild)
96d887e8
PH
5194{
5195 struct dict_iterator iter;
5196 int name_len = strlen (name);
5197 /* A matching argument symbol, if any. */
5198 struct symbol *arg_sym;
5199 /* Set true when we find a matching non-argument symbol. */
5200 int found_sym;
5201 struct symbol *sym;
5202
5203 arg_sym = NULL;
5204 found_sym = 0;
5205 if (wild)
5206 {
5207 struct symbol *sym;
5208 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 5209 {
5eeb2539
AR
5210 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5211 SYMBOL_DOMAIN (sym), domain)
1265e4aa 5212 && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (sym)))
76a01679 5213 {
2a2d4dc3
AS
5214 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5215 continue;
5216 else if (SYMBOL_IS_ARGUMENT (sym))
5217 arg_sym = sym;
5218 else
5219 {
76a01679
JB
5220 found_sym = 1;
5221 add_defn_to_vec (obstackp,
5222 fixup_symbol_section (sym, objfile),
2570f2b7 5223 block);
76a01679
JB
5224 }
5225 }
5226 }
96d887e8
PH
5227 }
5228 else
5229 {
5230 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 5231 {
5eeb2539
AR
5232 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5233 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
5234 {
5235 int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym), name_len);
5236 if (cmp == 0
5237 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len))
5238 {
2a2d4dc3
AS
5239 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5240 {
5241 if (SYMBOL_IS_ARGUMENT (sym))
5242 arg_sym = sym;
5243 else
5244 {
5245 found_sym = 1;
5246 add_defn_to_vec (obstackp,
5247 fixup_symbol_section (sym, objfile),
5248 block);
5249 }
5250 }
76a01679
JB
5251 }
5252 }
5253 }
96d887e8
PH
5254 }
5255
5256 if (!found_sym && arg_sym != NULL)
5257 {
76a01679
JB
5258 add_defn_to_vec (obstackp,
5259 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5260 block);
96d887e8
PH
5261 }
5262
5263 if (!wild)
5264 {
5265 arg_sym = NULL;
5266 found_sym = 0;
5267
5268 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 5269 {
5eeb2539
AR
5270 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5271 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
5272 {
5273 int cmp;
5274
5275 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5276 if (cmp == 0)
5277 {
5278 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5279 if (cmp == 0)
5280 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5281 name_len);
5282 }
5283
5284 if (cmp == 0
5285 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5286 {
2a2d4dc3
AS
5287 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5288 {
5289 if (SYMBOL_IS_ARGUMENT (sym))
5290 arg_sym = sym;
5291 else
5292 {
5293 found_sym = 1;
5294 add_defn_to_vec (obstackp,
5295 fixup_symbol_section (sym, objfile),
5296 block);
5297 }
5298 }
76a01679
JB
5299 }
5300 }
76a01679 5301 }
96d887e8
PH
5302
5303 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5304 They aren't parameters, right? */
5305 if (!found_sym && arg_sym != NULL)
5306 {
5307 add_defn_to_vec (obstackp,
76a01679 5308 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5309 block);
96d887e8
PH
5310 }
5311 }
5312}
5313\f
41d27058
JB
5314
5315 /* Symbol Completion */
5316
5317/* If SYM_NAME is a completion candidate for TEXT, return this symbol
5318 name in a form that's appropriate for the completion. The result
5319 does not need to be deallocated, but is only good until the next call.
5320
5321 TEXT_LEN is equal to the length of TEXT.
5322 Perform a wild match if WILD_MATCH is set.
5323 ENCODED should be set if TEXT represents the start of a symbol name
5324 in its encoded form. */
5325
5326static const char *
5327symbol_completion_match (const char *sym_name,
5328 const char *text, int text_len,
5329 int wild_match, int encoded)
5330{
5331 char *result;
5332 const int verbatim_match = (text[0] == '<');
5333 int match = 0;
5334
5335 if (verbatim_match)
5336 {
5337 /* Strip the leading angle bracket. */
5338 text = text + 1;
5339 text_len--;
5340 }
5341
5342 /* First, test against the fully qualified name of the symbol. */
5343
5344 if (strncmp (sym_name, text, text_len) == 0)
5345 match = 1;
5346
5347 if (match && !encoded)
5348 {
5349 /* One needed check before declaring a positive match is to verify
5350 that iff we are doing a verbatim match, the decoded version
5351 of the symbol name starts with '<'. Otherwise, this symbol name
5352 is not a suitable completion. */
5353 const char *sym_name_copy = sym_name;
5354 int has_angle_bracket;
5355
5356 sym_name = ada_decode (sym_name);
5357 has_angle_bracket = (sym_name[0] == '<');
5358 match = (has_angle_bracket == verbatim_match);
5359 sym_name = sym_name_copy;
5360 }
5361
5362 if (match && !verbatim_match)
5363 {
5364 /* When doing non-verbatim match, another check that needs to
5365 be done is to verify that the potentially matching symbol name
5366 does not include capital letters, because the ada-mode would
5367 not be able to understand these symbol names without the
5368 angle bracket notation. */
5369 const char *tmp;
5370
5371 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5372 if (*tmp != '\0')
5373 match = 0;
5374 }
5375
5376 /* Second: Try wild matching... */
5377
5378 if (!match && wild_match)
5379 {
5380 /* Since we are doing wild matching, this means that TEXT
5381 may represent an unqualified symbol name. We therefore must
5382 also compare TEXT against the unqualified name of the symbol. */
5383 sym_name = ada_unqualified_name (ada_decode (sym_name));
5384
5385 if (strncmp (sym_name, text, text_len) == 0)
5386 match = 1;
5387 }
5388
5389 /* Finally: If we found a mach, prepare the result to return. */
5390
5391 if (!match)
5392 return NULL;
5393
5394 if (verbatim_match)
5395 sym_name = add_angle_brackets (sym_name);
5396
5397 if (!encoded)
5398 sym_name = ada_decode (sym_name);
5399
5400 return sym_name;
5401}
5402
2ba95b9b
JB
5403typedef char *char_ptr;
5404DEF_VEC_P (char_ptr);
5405
41d27058
JB
5406/* A companion function to ada_make_symbol_completion_list().
5407 Check if SYM_NAME represents a symbol which name would be suitable
5408 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5409 it is appended at the end of the given string vector SV.
5410
5411 ORIG_TEXT is the string original string from the user command
5412 that needs to be completed. WORD is the entire command on which
5413 completion should be performed. These two parameters are used to
5414 determine which part of the symbol name should be added to the
5415 completion vector.
5416 if WILD_MATCH is set, then wild matching is performed.
5417 ENCODED should be set if TEXT represents a symbol name in its
5418 encoded formed (in which case the completion should also be
5419 encoded). */
5420
5421static void
d6565258 5422symbol_completion_add (VEC(char_ptr) **sv,
41d27058
JB
5423 const char *sym_name,
5424 const char *text, int text_len,
5425 const char *orig_text, const char *word,
5426 int wild_match, int encoded)
5427{
5428 const char *match = symbol_completion_match (sym_name, text, text_len,
5429 wild_match, encoded);
5430 char *completion;
5431
5432 if (match == NULL)
5433 return;
5434
5435 /* We found a match, so add the appropriate completion to the given
5436 string vector. */
5437
5438 if (word == orig_text)
5439 {
5440 completion = xmalloc (strlen (match) + 5);
5441 strcpy (completion, match);
5442 }
5443 else if (word > orig_text)
5444 {
5445 /* Return some portion of sym_name. */
5446 completion = xmalloc (strlen (match) + 5);
5447 strcpy (completion, match + (word - orig_text));
5448 }
5449 else
5450 {
5451 /* Return some of ORIG_TEXT plus sym_name. */
5452 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
5453 strncpy (completion, word, orig_text - word);
5454 completion[orig_text - word] = '\0';
5455 strcat (completion, match);
5456 }
5457
d6565258 5458 VEC_safe_push (char_ptr, *sv, completion);
41d27058
JB
5459}
5460
5461/* Return a list of possible symbol names completing TEXT0. The list
5462 is NULL terminated. WORD is the entire command on which completion
5463 is made. */
5464
5465static char **
5466ada_make_symbol_completion_list (char *text0, char *word)
5467{
5468 char *text;
5469 int text_len;
5470 int wild_match;
5471 int encoded;
2ba95b9b 5472 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
41d27058
JB
5473 struct symbol *sym;
5474 struct symtab *s;
5475 struct partial_symtab *ps;
5476 struct minimal_symbol *msymbol;
5477 struct objfile *objfile;
5478 struct block *b, *surrounding_static_block = 0;
5479 int i;
5480 struct dict_iterator iter;
5481
5482 if (text0[0] == '<')
5483 {
5484 text = xstrdup (text0);
5485 make_cleanup (xfree, text);
5486 text_len = strlen (text);
5487 wild_match = 0;
5488 encoded = 1;
5489 }
5490 else
5491 {
5492 text = xstrdup (ada_encode (text0));
5493 make_cleanup (xfree, text);
5494 text_len = strlen (text);
5495 for (i = 0; i < text_len; i++)
5496 text[i] = tolower (text[i]);
5497
5498 encoded = (strstr (text0, "__") != NULL);
5499 /* If the name contains a ".", then the user is entering a fully
5500 qualified entity name, and the match must not be done in wild
5501 mode. Similarly, if the user wants to complete what looks like
5502 an encoded name, the match must not be done in wild mode. */
5503 wild_match = (strchr (text0, '.') == NULL && !encoded);
5504 }
5505
5506 /* First, look at the partial symtab symbols. */
5507 ALL_PSYMTABS (objfile, ps)
5508 {
5509 struct partial_symbol **psym;
5510
5511 /* If the psymtab's been read in we'll get it when we search
5512 through the blockvector. */
5513 if (ps->readin)
5514 continue;
5515
5516 for (psym = objfile->global_psymbols.list + ps->globals_offset;
5517 psym < (objfile->global_psymbols.list + ps->globals_offset
5518 + ps->n_global_syms); psym++)
5519 {
5520 QUIT;
d6565258 5521 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (*psym),
41d27058
JB
5522 text, text_len, text0, word,
5523 wild_match, encoded);
5524 }
5525
5526 for (psym = objfile->static_psymbols.list + ps->statics_offset;
5527 psym < (objfile->static_psymbols.list + ps->statics_offset
5528 + ps->n_static_syms); psym++)
5529 {
5530 QUIT;
d6565258 5531 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (*psym),
41d27058
JB
5532 text, text_len, text0, word,
5533 wild_match, encoded);
5534 }
5535 }
5536
5537 /* At this point scan through the misc symbol vectors and add each
5538 symbol you find to the list. Eventually we want to ignore
5539 anything that isn't a text symbol (everything else will be
5540 handled by the psymtab code above). */
5541
5542 ALL_MSYMBOLS (objfile, msymbol)
5543 {
5544 QUIT;
d6565258 5545 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol),
41d27058
JB
5546 text, text_len, text0, word, wild_match, encoded);
5547 }
5548
5549 /* Search upwards from currently selected frame (so that we can
5550 complete on local vars. */
5551
5552 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
5553 {
5554 if (!BLOCK_SUPERBLOCK (b))
5555 surrounding_static_block = b; /* For elmin of dups */
5556
5557 ALL_BLOCK_SYMBOLS (b, iter, sym)
5558 {
d6565258 5559 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058
JB
5560 text, text_len, text0, word,
5561 wild_match, encoded);
5562 }
5563 }
5564
5565 /* Go through the symtabs and check the externs and statics for
5566 symbols which match. */
5567
5568 ALL_SYMTABS (objfile, s)
5569 {
5570 QUIT;
5571 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
5572 ALL_BLOCK_SYMBOLS (b, iter, sym)
5573 {
d6565258 5574 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058
JB
5575 text, text_len, text0, word,
5576 wild_match, encoded);
5577 }
5578 }
5579
5580 ALL_SYMTABS (objfile, s)
5581 {
5582 QUIT;
5583 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
5584 /* Don't do this block twice. */
5585 if (b == surrounding_static_block)
5586 continue;
5587 ALL_BLOCK_SYMBOLS (b, iter, sym)
5588 {
d6565258 5589 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058
JB
5590 text, text_len, text0, word,
5591 wild_match, encoded);
5592 }
5593 }
5594
5595 /* Append the closing NULL entry. */
2ba95b9b 5596 VEC_safe_push (char_ptr, completions, NULL);
41d27058 5597
2ba95b9b
JB
5598 /* Make a copy of the COMPLETIONS VEC before we free it, and then
5599 return the copy. It's unfortunate that we have to make a copy
5600 of an array that we're about to destroy, but there is nothing much
5601 we can do about it. Fortunately, it's typically not a very large
5602 array. */
5603 {
5604 const size_t completions_size =
5605 VEC_length (char_ptr, completions) * sizeof (char *);
5606 char **result = malloc (completions_size);
5607
5608 memcpy (result, VEC_address (char_ptr, completions), completions_size);
5609
5610 VEC_free (char_ptr, completions);
5611 return result;
5612 }
41d27058
JB
5613}
5614
963a6417 5615 /* Field Access */
96d887e8 5616
73fb9985
JB
5617/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5618 for tagged types. */
5619
5620static int
5621ada_is_dispatch_table_ptr_type (struct type *type)
5622{
5623 char *name;
5624
5625 if (TYPE_CODE (type) != TYPE_CODE_PTR)
5626 return 0;
5627
5628 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
5629 if (name == NULL)
5630 return 0;
5631
5632 return (strcmp (name, "ada__tags__dispatch_table") == 0);
5633}
5634
963a6417
PH
5635/* True if field number FIELD_NUM in struct or union type TYPE is supposed
5636 to be invisible to users. */
96d887e8 5637
963a6417
PH
5638int
5639ada_is_ignored_field (struct type *type, int field_num)
96d887e8 5640{
963a6417
PH
5641 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
5642 return 1;
73fb9985
JB
5643
5644 /* Check the name of that field. */
5645 {
5646 const char *name = TYPE_FIELD_NAME (type, field_num);
5647
5648 /* Anonymous field names should not be printed.
5649 brobecker/2007-02-20: I don't think this can actually happen
5650 but we don't want to print the value of annonymous fields anyway. */
5651 if (name == NULL)
5652 return 1;
5653
5654 /* A field named "_parent" is internally generated by GNAT for
5655 tagged types, and should not be printed either. */
5656 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
5657 return 1;
5658 }
5659
5660 /* If this is the dispatch table of a tagged type, then ignore. */
5661 if (ada_is_tagged_type (type, 1)
5662 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num)))
5663 return 1;
5664
5665 /* Not a special field, so it should not be ignored. */
5666 return 0;
963a6417 5667}
96d887e8 5668
963a6417
PH
5669/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5670 pointer or reference type whose ultimate target has a tag field. */
96d887e8 5671
963a6417
PH
5672int
5673ada_is_tagged_type (struct type *type, int refok)
5674{
5675 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
5676}
96d887e8 5677
963a6417 5678/* True iff TYPE represents the type of X'Tag */
96d887e8 5679
963a6417
PH
5680int
5681ada_is_tag_type (struct type *type)
5682{
5683 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
5684 return 0;
5685 else
96d887e8 5686 {
963a6417
PH
5687 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5688 return (name != NULL
5689 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 5690 }
96d887e8
PH
5691}
5692
963a6417 5693/* The type of the tag on VAL. */
76a01679 5694
963a6417
PH
5695struct type *
5696ada_tag_type (struct value *val)
96d887e8 5697{
df407dfe 5698 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
963a6417 5699}
96d887e8 5700
963a6417 5701/* The value of the tag on VAL. */
96d887e8 5702
963a6417
PH
5703struct value *
5704ada_value_tag (struct value *val)
5705{
03ee6b2e 5706 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
5707}
5708
963a6417
PH
5709/* The value of the tag on the object of type TYPE whose contents are
5710 saved at VALADDR, if it is non-null, or is at memory address
5711 ADDRESS. */
96d887e8 5712
963a6417 5713static struct value *
10a2c479 5714value_tag_from_contents_and_address (struct type *type,
fc1a4b47 5715 const gdb_byte *valaddr,
963a6417 5716 CORE_ADDR address)
96d887e8 5717{
963a6417
PH
5718 int tag_byte_offset, dummy1, dummy2;
5719 struct type *tag_type;
5720 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 5721 NULL, NULL, NULL))
96d887e8 5722 {
fc1a4b47 5723 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
5724 ? NULL
5725 : valaddr + tag_byte_offset);
963a6417 5726 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 5727
963a6417 5728 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 5729 }
963a6417
PH
5730 return NULL;
5731}
96d887e8 5732
963a6417
PH
5733static struct type *
5734type_from_tag (struct value *tag)
5735{
5736 const char *type_name = ada_tag_name (tag);
5737 if (type_name != NULL)
5738 return ada_find_any_type (ada_encode (type_name));
5739 return NULL;
5740}
96d887e8 5741
963a6417
PH
5742struct tag_args
5743{
5744 struct value *tag;
5745 char *name;
5746};
4c4b4cd2 5747
529cad9c
PH
5748
5749static int ada_tag_name_1 (void *);
5750static int ada_tag_name_2 (struct tag_args *);
5751
4c4b4cd2
PH
5752/* Wrapper function used by ada_tag_name. Given a struct tag_args*
5753 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5754 The value stored in ARGS->name is valid until the next call to
5755 ada_tag_name_1. */
5756
5757static int
5758ada_tag_name_1 (void *args0)
5759{
5760 struct tag_args *args = (struct tag_args *) args0;
5761 static char name[1024];
76a01679 5762 char *p;
4c4b4cd2
PH
5763 struct value *val;
5764 args->name = NULL;
03ee6b2e 5765 val = ada_value_struct_elt (args->tag, "tsd", 1);
529cad9c
PH
5766 if (val == NULL)
5767 return ada_tag_name_2 (args);
03ee6b2e 5768 val = ada_value_struct_elt (val, "expanded_name", 1);
529cad9c
PH
5769 if (val == NULL)
5770 return 0;
5771 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
5772 for (p = name; *p != '\0'; p += 1)
5773 if (isalpha (*p))
5774 *p = tolower (*p);
5775 args->name = name;
5776 return 0;
5777}
5778
5779/* Utility function for ada_tag_name_1 that tries the second
5780 representation for the dispatch table (in which there is no
5781 explicit 'tsd' field in the referent of the tag pointer, and instead
5782 the tsd pointer is stored just before the dispatch table. */
5783
5784static int
5785ada_tag_name_2 (struct tag_args *args)
5786{
5787 struct type *info_type;
5788 static char name[1024];
5789 char *p;
5790 struct value *val, *valp;
5791
5792 args->name = NULL;
5793 info_type = ada_find_any_type ("ada__tags__type_specific_data");
5794 if (info_type == NULL)
5795 return 0;
5796 info_type = lookup_pointer_type (lookup_pointer_type (info_type));
5797 valp = value_cast (info_type, args->tag);
5798 if (valp == NULL)
5799 return 0;
5800 val = value_ind (value_add (valp, value_from_longest (builtin_type_int, -1)));
4c4b4cd2
PH
5801 if (val == NULL)
5802 return 0;
03ee6b2e 5803 val = ada_value_struct_elt (val, "expanded_name", 1);
4c4b4cd2
PH
5804 if (val == NULL)
5805 return 0;
5806 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
5807 for (p = name; *p != '\0'; p += 1)
5808 if (isalpha (*p))
5809 *p = tolower (*p);
5810 args->name = name;
5811 return 0;
5812}
5813
5814/* The type name of the dynamic type denoted by the 'tag value TAG, as
5815 * a C string. */
5816
5817const char *
5818ada_tag_name (struct value *tag)
5819{
5820 struct tag_args args;
df407dfe 5821 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 5822 return NULL;
76a01679 5823 args.tag = tag;
4c4b4cd2
PH
5824 args.name = NULL;
5825 catch_errors (ada_tag_name_1, &args, NULL, RETURN_MASK_ALL);
5826 return args.name;
5827}
5828
5829/* The parent type of TYPE, or NULL if none. */
14f9c5c9 5830
d2e4a39e 5831struct type *
ebf56fd3 5832ada_parent_type (struct type *type)
14f9c5c9
AS
5833{
5834 int i;
5835
61ee279c 5836 type = ada_check_typedef (type);
14f9c5c9
AS
5837
5838 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5839 return NULL;
5840
5841 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5842 if (ada_is_parent_field (type, i))
61ee279c 5843 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
14f9c5c9
AS
5844
5845 return NULL;
5846}
5847
4c4b4cd2
PH
5848/* True iff field number FIELD_NUM of structure type TYPE contains the
5849 parent-type (inherited) fields of a derived type. Assumes TYPE is
5850 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
5851
5852int
ebf56fd3 5853ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 5854{
61ee279c 5855 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
4c4b4cd2
PH
5856 return (name != NULL
5857 && (strncmp (name, "PARENT", 6) == 0
5858 || strncmp (name, "_parent", 7) == 0));
14f9c5c9
AS
5859}
5860
4c4b4cd2 5861/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 5862 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 5863 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 5864 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 5865 structures. */
14f9c5c9
AS
5866
5867int
ebf56fd3 5868ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 5869{
d2e4a39e
AS
5870 const char *name = TYPE_FIELD_NAME (type, field_num);
5871 return (name != NULL
4c4b4cd2
PH
5872 && (strncmp (name, "PARENT", 6) == 0
5873 || strcmp (name, "REP") == 0
5874 || strncmp (name, "_parent", 7) == 0
5875 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
5876}
5877
4c4b4cd2
PH
5878/* True iff field number FIELD_NUM of structure or union type TYPE
5879 is a variant wrapper. Assumes TYPE is a structure type with at least
5880 FIELD_NUM+1 fields. */
14f9c5c9
AS
5881
5882int
ebf56fd3 5883ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 5884{
d2e4a39e 5885 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
14f9c5c9 5886 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 5887 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
5888 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
5889 == TYPE_CODE_UNION)));
14f9c5c9
AS
5890}
5891
5892/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 5893 whose discriminants are contained in the record type OUTER_TYPE,
14f9c5c9
AS
5894 returns the type of the controlling discriminant for the variant. */
5895
d2e4a39e 5896struct type *
ebf56fd3 5897ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 5898{
d2e4a39e 5899 char *name = ada_variant_discrim_name (var_type);
76a01679 5900 struct type *type =
4c4b4cd2 5901 ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
14f9c5c9
AS
5902 if (type == NULL)
5903 return builtin_type_int;
5904 else
5905 return type;
5906}
5907
4c4b4cd2 5908/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 5909 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 5910 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
5911
5912int
ebf56fd3 5913ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 5914{
d2e4a39e 5915 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
5916 return (name != NULL && name[0] == 'O');
5917}
5918
5919/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
5920 returns the name of the discriminant controlling the variant.
5921 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 5922
d2e4a39e 5923char *
ebf56fd3 5924ada_variant_discrim_name (struct type *type0)
14f9c5c9 5925{
d2e4a39e 5926 static char *result = NULL;
14f9c5c9 5927 static size_t result_len = 0;
d2e4a39e
AS
5928 struct type *type;
5929 const char *name;
5930 const char *discrim_end;
5931 const char *discrim_start;
14f9c5c9
AS
5932
5933 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
5934 type = TYPE_TARGET_TYPE (type0);
5935 else
5936 type = type0;
5937
5938 name = ada_type_name (type);
5939
5940 if (name == NULL || name[0] == '\000')
5941 return "";
5942
5943 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
5944 discrim_end -= 1)
5945 {
4c4b4cd2
PH
5946 if (strncmp (discrim_end, "___XVN", 6) == 0)
5947 break;
14f9c5c9
AS
5948 }
5949 if (discrim_end == name)
5950 return "";
5951
d2e4a39e 5952 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
5953 discrim_start -= 1)
5954 {
d2e4a39e 5955 if (discrim_start == name + 1)
4c4b4cd2 5956 return "";
76a01679 5957 if ((discrim_start > name + 3
4c4b4cd2
PH
5958 && strncmp (discrim_start - 3, "___", 3) == 0)
5959 || discrim_start[-1] == '.')
5960 break;
14f9c5c9
AS
5961 }
5962
5963 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
5964 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 5965 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
5966 return result;
5967}
5968
4c4b4cd2
PH
5969/* Scan STR for a subtype-encoded number, beginning at position K.
5970 Put the position of the character just past the number scanned in
5971 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5972 Return 1 if there was a valid number at the given position, and 0
5973 otherwise. A "subtype-encoded" number consists of the absolute value
5974 in decimal, followed by the letter 'm' to indicate a negative number.
5975 Assumes 0m does not occur. */
14f9c5c9
AS
5976
5977int
d2e4a39e 5978ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
5979{
5980 ULONGEST RU;
5981
d2e4a39e 5982 if (!isdigit (str[k]))
14f9c5c9
AS
5983 return 0;
5984
4c4b4cd2 5985 /* Do it the hard way so as not to make any assumption about
14f9c5c9 5986 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 5987 LONGEST. */
14f9c5c9
AS
5988 RU = 0;
5989 while (isdigit (str[k]))
5990 {
d2e4a39e 5991 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
5992 k += 1;
5993 }
5994
d2e4a39e 5995 if (str[k] == 'm')
14f9c5c9
AS
5996 {
5997 if (R != NULL)
4c4b4cd2 5998 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
5999 k += 1;
6000 }
6001 else if (R != NULL)
6002 *R = (LONGEST) RU;
6003
4c4b4cd2 6004 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
6005 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6006 number representable as a LONGEST (although either would probably work
6007 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 6008 above is always equivalent to the negative of RU. */
14f9c5c9
AS
6009
6010 if (new_k != NULL)
6011 *new_k = k;
6012 return 1;
6013}
6014
4c4b4cd2
PH
6015/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6016 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6017 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 6018
d2e4a39e 6019int
ebf56fd3 6020ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 6021{
d2e4a39e 6022 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
6023 int p;
6024
6025 p = 0;
6026 while (1)
6027 {
d2e4a39e 6028 switch (name[p])
4c4b4cd2
PH
6029 {
6030 case '\0':
6031 return 0;
6032 case 'S':
6033 {
6034 LONGEST W;
6035 if (!ada_scan_number (name, p + 1, &W, &p))
6036 return 0;
6037 if (val == W)
6038 return 1;
6039 break;
6040 }
6041 case 'R':
6042 {
6043 LONGEST L, U;
6044 if (!ada_scan_number (name, p + 1, &L, &p)
6045 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6046 return 0;
6047 if (val >= L && val <= U)
6048 return 1;
6049 break;
6050 }
6051 case 'O':
6052 return 1;
6053 default:
6054 return 0;
6055 }
6056 }
6057}
6058
6059/* FIXME: Lots of redundancy below. Try to consolidate. */
6060
6061/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6062 ARG_TYPE, extract and return the value of one of its (non-static)
6063 fields. FIELDNO says which field. Differs from value_primitive_field
6064 only in that it can handle packed values of arbitrary type. */
14f9c5c9 6065
4c4b4cd2 6066static struct value *
d2e4a39e 6067ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 6068 struct type *arg_type)
14f9c5c9 6069{
14f9c5c9
AS
6070 struct type *type;
6071
61ee279c 6072 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
6073 type = TYPE_FIELD_TYPE (arg_type, fieldno);
6074
4c4b4cd2 6075 /* Handle packed fields. */
14f9c5c9
AS
6076
6077 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
6078 {
6079 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6080 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 6081
0fd88904 6082 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
6083 offset + bit_pos / 8,
6084 bit_pos % 8, bit_size, type);
14f9c5c9
AS
6085 }
6086 else
6087 return value_primitive_field (arg1, offset, fieldno, arg_type);
6088}
6089
52ce6436
PH
6090/* Find field with name NAME in object of type TYPE. If found,
6091 set the following for each argument that is non-null:
6092 - *FIELD_TYPE_P to the field's type;
6093 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6094 an object of that type;
6095 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6096 - *BIT_SIZE_P to its size in bits if the field is packed, and
6097 0 otherwise;
6098 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6099 fields up to but not including the desired field, or by the total
6100 number of fields if not found. A NULL value of NAME never
6101 matches; the function just counts visible fields in this case.
6102
6103 Returns 1 if found, 0 otherwise. */
6104
4c4b4cd2 6105static int
76a01679
JB
6106find_struct_field (char *name, struct type *type, int offset,
6107 struct type **field_type_p,
52ce6436
PH
6108 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6109 int *index_p)
4c4b4cd2
PH
6110{
6111 int i;
6112
61ee279c 6113 type = ada_check_typedef (type);
76a01679 6114
52ce6436
PH
6115 if (field_type_p != NULL)
6116 *field_type_p = NULL;
6117 if (byte_offset_p != NULL)
d5d6fca5 6118 *byte_offset_p = 0;
52ce6436
PH
6119 if (bit_offset_p != NULL)
6120 *bit_offset_p = 0;
6121 if (bit_size_p != NULL)
6122 *bit_size_p = 0;
6123
6124 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
6125 {
6126 int bit_pos = TYPE_FIELD_BITPOS (type, i);
6127 int fld_offset = offset + bit_pos / 8;
6128 char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 6129
4c4b4cd2
PH
6130 if (t_field_name == NULL)
6131 continue;
6132
52ce6436 6133 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
6134 {
6135 int bit_size = TYPE_FIELD_BITSIZE (type, i);
52ce6436
PH
6136 if (field_type_p != NULL)
6137 *field_type_p = TYPE_FIELD_TYPE (type, i);
6138 if (byte_offset_p != NULL)
6139 *byte_offset_p = fld_offset;
6140 if (bit_offset_p != NULL)
6141 *bit_offset_p = bit_pos % 8;
6142 if (bit_size_p != NULL)
6143 *bit_size_p = bit_size;
76a01679
JB
6144 return 1;
6145 }
4c4b4cd2
PH
6146 else if (ada_is_wrapper_field (type, i))
6147 {
52ce6436
PH
6148 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
6149 field_type_p, byte_offset_p, bit_offset_p,
6150 bit_size_p, index_p))
76a01679
JB
6151 return 1;
6152 }
4c4b4cd2
PH
6153 else if (ada_is_variant_part (type, i))
6154 {
52ce6436
PH
6155 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6156 fixed type?? */
4c4b4cd2 6157 int j;
52ce6436
PH
6158 struct type *field_type
6159 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 6160
52ce6436 6161 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6162 {
76a01679
JB
6163 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
6164 fld_offset
6165 + TYPE_FIELD_BITPOS (field_type, j) / 8,
6166 field_type_p, byte_offset_p,
52ce6436 6167 bit_offset_p, bit_size_p, index_p))
76a01679 6168 return 1;
4c4b4cd2
PH
6169 }
6170 }
52ce6436
PH
6171 else if (index_p != NULL)
6172 *index_p += 1;
4c4b4cd2
PH
6173 }
6174 return 0;
6175}
6176
52ce6436 6177/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 6178
52ce6436
PH
6179static int
6180num_visible_fields (struct type *type)
6181{
6182 int n;
6183 n = 0;
6184 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6185 return n;
6186}
14f9c5c9 6187
4c4b4cd2 6188/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
6189 and search in it assuming it has (class) type TYPE.
6190 If found, return value, else return NULL.
6191
4c4b4cd2 6192 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 6193
4c4b4cd2 6194static struct value *
d2e4a39e 6195ada_search_struct_field (char *name, struct value *arg, int offset,
4c4b4cd2 6196 struct type *type)
14f9c5c9
AS
6197{
6198 int i;
61ee279c 6199 type = ada_check_typedef (type);
14f9c5c9 6200
52ce6436 6201 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9
AS
6202 {
6203 char *t_field_name = TYPE_FIELD_NAME (type, i);
6204
6205 if (t_field_name == NULL)
4c4b4cd2 6206 continue;
14f9c5c9
AS
6207
6208 else if (field_name_match (t_field_name, name))
4c4b4cd2 6209 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
6210
6211 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 6212 {
06d5cf63
JB
6213 struct value *v = /* Do not let indent join lines here. */
6214 ada_search_struct_field (name, arg,
6215 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6216 TYPE_FIELD_TYPE (type, i));
4c4b4cd2
PH
6217 if (v != NULL)
6218 return v;
6219 }
14f9c5c9
AS
6220
6221 else if (ada_is_variant_part (type, i))
4c4b4cd2 6222 {
52ce6436 6223 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 6224 int j;
61ee279c 6225 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2
PH
6226 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6227
52ce6436 6228 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6229 {
06d5cf63
JB
6230 struct value *v = ada_search_struct_field /* Force line break. */
6231 (name, arg,
6232 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6233 TYPE_FIELD_TYPE (field_type, j));
4c4b4cd2
PH
6234 if (v != NULL)
6235 return v;
6236 }
6237 }
14f9c5c9
AS
6238 }
6239 return NULL;
6240}
d2e4a39e 6241
52ce6436
PH
6242static struct value *ada_index_struct_field_1 (int *, struct value *,
6243 int, struct type *);
6244
6245
6246/* Return field #INDEX in ARG, where the index is that returned by
6247 * find_struct_field through its INDEX_P argument. Adjust the address
6248 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6249 * If found, return value, else return NULL. */
6250
6251static struct value *
6252ada_index_struct_field (int index, struct value *arg, int offset,
6253 struct type *type)
6254{
6255 return ada_index_struct_field_1 (&index, arg, offset, type);
6256}
6257
6258
6259/* Auxiliary function for ada_index_struct_field. Like
6260 * ada_index_struct_field, but takes index from *INDEX_P and modifies
6261 * *INDEX_P. */
6262
6263static struct value *
6264ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6265 struct type *type)
6266{
6267 int i;
6268 type = ada_check_typedef (type);
6269
6270 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6271 {
6272 if (TYPE_FIELD_NAME (type, i) == NULL)
6273 continue;
6274 else if (ada_is_wrapper_field (type, i))
6275 {
6276 struct value *v = /* Do not let indent join lines here. */
6277 ada_index_struct_field_1 (index_p, arg,
6278 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6279 TYPE_FIELD_TYPE (type, i));
6280 if (v != NULL)
6281 return v;
6282 }
6283
6284 else if (ada_is_variant_part (type, i))
6285 {
6286 /* PNH: Do we ever get here? See ada_search_struct_field,
6287 find_struct_field. */
6288 error (_("Cannot assign this kind of variant record"));
6289 }
6290 else if (*index_p == 0)
6291 return ada_value_primitive_field (arg, offset, i, type);
6292 else
6293 *index_p -= 1;
6294 }
6295 return NULL;
6296}
6297
4c4b4cd2
PH
6298/* Given ARG, a value of type (pointer or reference to a)*
6299 structure/union, extract the component named NAME from the ultimate
6300 target structure/union and return it as a value with its
6301 appropriate type. If ARG is a pointer or reference and the field
6302 is not packed, returns a reference to the field, otherwise the
6303 value of the field (an lvalue if ARG is an lvalue).
14f9c5c9 6304
4c4b4cd2
PH
6305 The routine searches for NAME among all members of the structure itself
6306 and (recursively) among all members of any wrapper members
14f9c5c9
AS
6307 (e.g., '_parent').
6308
03ee6b2e
PH
6309 If NO_ERR, then simply return NULL in case of error, rather than
6310 calling error. */
14f9c5c9 6311
d2e4a39e 6312struct value *
03ee6b2e 6313ada_value_struct_elt (struct value *arg, char *name, int no_err)
14f9c5c9 6314{
4c4b4cd2 6315 struct type *t, *t1;
d2e4a39e 6316 struct value *v;
14f9c5c9 6317
4c4b4cd2 6318 v = NULL;
df407dfe 6319 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
6320 if (TYPE_CODE (t) == TYPE_CODE_REF)
6321 {
6322 t1 = TYPE_TARGET_TYPE (t);
6323 if (t1 == NULL)
03ee6b2e 6324 goto BadValue;
61ee279c 6325 t1 = ada_check_typedef (t1);
4c4b4cd2 6326 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 6327 {
994b9211 6328 arg = coerce_ref (arg);
76a01679
JB
6329 t = t1;
6330 }
4c4b4cd2 6331 }
14f9c5c9 6332
4c4b4cd2
PH
6333 while (TYPE_CODE (t) == TYPE_CODE_PTR)
6334 {
6335 t1 = TYPE_TARGET_TYPE (t);
6336 if (t1 == NULL)
03ee6b2e 6337 goto BadValue;
61ee279c 6338 t1 = ada_check_typedef (t1);
4c4b4cd2 6339 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
6340 {
6341 arg = value_ind (arg);
6342 t = t1;
6343 }
4c4b4cd2 6344 else
76a01679 6345 break;
4c4b4cd2 6346 }
14f9c5c9 6347
4c4b4cd2 6348 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 6349 goto BadValue;
14f9c5c9 6350
4c4b4cd2
PH
6351 if (t1 == t)
6352 v = ada_search_struct_field (name, arg, 0, t);
6353 else
6354 {
6355 int bit_offset, bit_size, byte_offset;
6356 struct type *field_type;
6357 CORE_ADDR address;
6358
76a01679
JB
6359 if (TYPE_CODE (t) == TYPE_CODE_PTR)
6360 address = value_as_address (arg);
4c4b4cd2 6361 else
0fd88904 6362 address = unpack_pointer (t, value_contents (arg));
14f9c5c9 6363
1ed6ede0 6364 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
76a01679
JB
6365 if (find_struct_field (name, t1, 0,
6366 &field_type, &byte_offset, &bit_offset,
52ce6436 6367 &bit_size, NULL))
76a01679
JB
6368 {
6369 if (bit_size != 0)
6370 {
714e53ab
PH
6371 if (TYPE_CODE (t) == TYPE_CODE_REF)
6372 arg = ada_coerce_ref (arg);
6373 else
6374 arg = ada_value_ind (arg);
76a01679
JB
6375 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
6376 bit_offset, bit_size,
6377 field_type);
6378 }
6379 else
6380 v = value_from_pointer (lookup_reference_type (field_type),
6381 address + byte_offset);
6382 }
6383 }
6384
03ee6b2e
PH
6385 if (v != NULL || no_err)
6386 return v;
6387 else
323e0a4a 6388 error (_("There is no member named %s."), name);
14f9c5c9 6389
03ee6b2e
PH
6390 BadValue:
6391 if (no_err)
6392 return NULL;
6393 else
6394 error (_("Attempt to extract a component of a value that is not a record."));
14f9c5c9
AS
6395}
6396
6397/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
6398 If DISPP is non-null, add its byte displacement from the beginning of a
6399 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
6400 work for packed fields).
6401
6402 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 6403 followed by "___".
14f9c5c9 6404
4c4b4cd2
PH
6405 TYPE can be either a struct or union. If REFOK, TYPE may also
6406 be a (pointer or reference)+ to a struct or union, and the
6407 ultimate target type will be searched.
14f9c5c9
AS
6408
6409 Looks recursively into variant clauses and parent types.
6410
4c4b4cd2
PH
6411 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6412 TYPE is not a type of the right kind. */
14f9c5c9 6413
4c4b4cd2 6414static struct type *
76a01679
JB
6415ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
6416 int noerr, int *dispp)
14f9c5c9
AS
6417{
6418 int i;
6419
6420 if (name == NULL)
6421 goto BadName;
6422
76a01679 6423 if (refok && type != NULL)
4c4b4cd2
PH
6424 while (1)
6425 {
61ee279c 6426 type = ada_check_typedef (type);
76a01679
JB
6427 if (TYPE_CODE (type) != TYPE_CODE_PTR
6428 && TYPE_CODE (type) != TYPE_CODE_REF)
6429 break;
6430 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 6431 }
14f9c5c9 6432
76a01679 6433 if (type == NULL
1265e4aa
JB
6434 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
6435 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 6436 {
4c4b4cd2 6437 if (noerr)
76a01679 6438 return NULL;
4c4b4cd2 6439 else
76a01679
JB
6440 {
6441 target_terminal_ours ();
6442 gdb_flush (gdb_stdout);
323e0a4a
AC
6443 if (type == NULL)
6444 error (_("Type (null) is not a structure or union type"));
6445 else
6446 {
6447 /* XXX: type_sprint */
6448 fprintf_unfiltered (gdb_stderr, _("Type "));
6449 type_print (type, "", gdb_stderr, -1);
6450 error (_(" is not a structure or union type"));
6451 }
76a01679 6452 }
14f9c5c9
AS
6453 }
6454
6455 type = to_static_fixed_type (type);
6456
6457 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6458 {
6459 char *t_field_name = TYPE_FIELD_NAME (type, i);
6460 struct type *t;
6461 int disp;
d2e4a39e 6462
14f9c5c9 6463 if (t_field_name == NULL)
4c4b4cd2 6464 continue;
14f9c5c9
AS
6465
6466 else if (field_name_match (t_field_name, name))
4c4b4cd2
PH
6467 {
6468 if (dispp != NULL)
6469 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
61ee279c 6470 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 6471 }
14f9c5c9
AS
6472
6473 else if (ada_is_wrapper_field (type, i))
4c4b4cd2
PH
6474 {
6475 disp = 0;
6476 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
6477 0, 1, &disp);
6478 if (t != NULL)
6479 {
6480 if (dispp != NULL)
6481 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6482 return t;
6483 }
6484 }
14f9c5c9
AS
6485
6486 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
6487 {
6488 int j;
61ee279c 6489 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2
PH
6490
6491 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
6492 {
6493 disp = 0;
6494 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
6495 name, 0, 1, &disp);
6496 if (t != NULL)
6497 {
6498 if (dispp != NULL)
6499 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6500 return t;
6501 }
6502 }
6503 }
14f9c5c9
AS
6504
6505 }
6506
6507BadName:
d2e4a39e 6508 if (!noerr)
14f9c5c9
AS
6509 {
6510 target_terminal_ours ();
6511 gdb_flush (gdb_stdout);
323e0a4a
AC
6512 if (name == NULL)
6513 {
6514 /* XXX: type_sprint */
6515 fprintf_unfiltered (gdb_stderr, _("Type "));
6516 type_print (type, "", gdb_stderr, -1);
6517 error (_(" has no component named <null>"));
6518 }
6519 else
6520 {
6521 /* XXX: type_sprint */
6522 fprintf_unfiltered (gdb_stderr, _("Type "));
6523 type_print (type, "", gdb_stderr, -1);
6524 error (_(" has no component named %s"), name);
6525 }
14f9c5c9
AS
6526 }
6527
6528 return NULL;
6529}
6530
6531/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6532 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
6533 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6534 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 6535
d2e4a39e 6536int
ebf56fd3 6537ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 6538 const gdb_byte *outer_valaddr)
14f9c5c9
AS
6539{
6540 int others_clause;
6541 int i;
d2e4a39e 6542 char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
6543 struct value *outer;
6544 struct value *discrim;
14f9c5c9
AS
6545 LONGEST discrim_val;
6546
0c281816
JB
6547 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
6548 discrim = ada_value_struct_elt (outer, discrim_name, 1);
6549 if (discrim == NULL)
14f9c5c9 6550 return -1;
0c281816 6551 discrim_val = value_as_long (discrim);
14f9c5c9
AS
6552
6553 others_clause = -1;
6554 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
6555 {
6556 if (ada_is_others_clause (var_type, i))
4c4b4cd2 6557 others_clause = i;
14f9c5c9 6558 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 6559 return i;
14f9c5c9
AS
6560 }
6561
6562 return others_clause;
6563}
d2e4a39e 6564\f
14f9c5c9
AS
6565
6566
4c4b4cd2 6567 /* Dynamic-Sized Records */
14f9c5c9
AS
6568
6569/* Strategy: The type ostensibly attached to a value with dynamic size
6570 (i.e., a size that is not statically recorded in the debugging
6571 data) does not accurately reflect the size or layout of the value.
6572 Our strategy is to convert these values to values with accurate,
4c4b4cd2 6573 conventional types that are constructed on the fly. */
14f9c5c9
AS
6574
6575/* There is a subtle and tricky problem here. In general, we cannot
6576 determine the size of dynamic records without its data. However,
6577 the 'struct value' data structure, which GDB uses to represent
6578 quantities in the inferior process (the target), requires the size
6579 of the type at the time of its allocation in order to reserve space
6580 for GDB's internal copy of the data. That's why the
6581 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 6582 rather than struct value*s.
14f9c5c9
AS
6583
6584 However, GDB's internal history variables ($1, $2, etc.) are
6585 struct value*s containing internal copies of the data that are not, in
6586 general, the same as the data at their corresponding addresses in
6587 the target. Fortunately, the types we give to these values are all
6588 conventional, fixed-size types (as per the strategy described
6589 above), so that we don't usually have to perform the
6590 'to_fixed_xxx_type' conversions to look at their values.
6591 Unfortunately, there is one exception: if one of the internal
6592 history variables is an array whose elements are unconstrained
6593 records, then we will need to create distinct fixed types for each
6594 element selected. */
6595
6596/* The upshot of all of this is that many routines take a (type, host
6597 address, target address) triple as arguments to represent a value.
6598 The host address, if non-null, is supposed to contain an internal
6599 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 6600 target at the target address. */
14f9c5c9
AS
6601
6602/* Assuming that VAL0 represents a pointer value, the result of
6603 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 6604 dynamic-sized types. */
14f9c5c9 6605
d2e4a39e
AS
6606struct value *
6607ada_value_ind (struct value *val0)
14f9c5c9 6608{
d2e4a39e 6609 struct value *val = unwrap_value (value_ind (val0));
4c4b4cd2 6610 return ada_to_fixed_value (val);
14f9c5c9
AS
6611}
6612
6613/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
6614 qualifiers on VAL0. */
6615
d2e4a39e
AS
6616static struct value *
6617ada_coerce_ref (struct value *val0)
6618{
df407dfe 6619 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
6620 {
6621 struct value *val = val0;
994b9211 6622 val = coerce_ref (val);
d2e4a39e 6623 val = unwrap_value (val);
4c4b4cd2 6624 return ada_to_fixed_value (val);
d2e4a39e
AS
6625 }
6626 else
14f9c5c9
AS
6627 return val0;
6628}
6629
6630/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 6631 ALIGNMENT (a power of 2). */
14f9c5c9
AS
6632
6633static unsigned int
ebf56fd3 6634align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
6635{
6636 return (off + alignment - 1) & ~(alignment - 1);
6637}
6638
4c4b4cd2 6639/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
6640
6641static unsigned int
ebf56fd3 6642field_alignment (struct type *type, int f)
14f9c5c9 6643{
d2e4a39e 6644 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 6645 int len;
14f9c5c9
AS
6646 int align_offset;
6647
64a1bf19
JB
6648 /* The field name should never be null, unless the debugging information
6649 is somehow malformed. In this case, we assume the field does not
6650 require any alignment. */
6651 if (name == NULL)
6652 return 1;
6653
6654 len = strlen (name);
6655
4c4b4cd2
PH
6656 if (!isdigit (name[len - 1]))
6657 return 1;
14f9c5c9 6658
d2e4a39e 6659 if (isdigit (name[len - 2]))
14f9c5c9
AS
6660 align_offset = len - 2;
6661 else
6662 align_offset = len - 1;
6663
4c4b4cd2 6664 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
14f9c5c9
AS
6665 return TARGET_CHAR_BIT;
6666
4c4b4cd2
PH
6667 return atoi (name + align_offset) * TARGET_CHAR_BIT;
6668}
6669
6670/* Find a symbol named NAME. Ignores ambiguity. */
6671
6672struct symbol *
6673ada_find_any_symbol (const char *name)
6674{
6675 struct symbol *sym;
6676
6677 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
6678 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
6679 return sym;
6680
6681 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
6682 return sym;
14f9c5c9
AS
6683}
6684
6685/* Find a type named NAME. Ignores ambiguity. */
4c4b4cd2 6686
d2e4a39e 6687struct type *
ebf56fd3 6688ada_find_any_type (const char *name)
14f9c5c9 6689{
4c4b4cd2 6690 struct symbol *sym = ada_find_any_symbol (name);
14f9c5c9 6691
14f9c5c9
AS
6692 if (sym != NULL)
6693 return SYMBOL_TYPE (sym);
6694
6695 return NULL;
6696}
6697
aeb5907d
JB
6698/* Given NAME and an associated BLOCK, search all symbols for
6699 NAME suffixed with "___XR", which is the ``renaming'' symbol
4c4b4cd2
PH
6700 associated to NAME. Return this symbol if found, return
6701 NULL otherwise. */
6702
6703struct symbol *
6704ada_find_renaming_symbol (const char *name, struct block *block)
aeb5907d
JB
6705{
6706 struct symbol *sym;
6707
6708 sym = find_old_style_renaming_symbol (name, block);
6709
6710 if (sym != NULL)
6711 return sym;
6712
6713 /* Not right yet. FIXME pnh 7/20/2007. */
6714 sym = ada_find_any_symbol (name);
6715 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
6716 return sym;
6717 else
6718 return NULL;
6719}
6720
6721static struct symbol *
6722find_old_style_renaming_symbol (const char *name, struct block *block)
4c4b4cd2 6723{
7f0df278 6724 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
6725 char *rename;
6726
6727 if (function_sym != NULL)
6728 {
6729 /* If the symbol is defined inside a function, NAME is not fully
6730 qualified. This means we need to prepend the function name
6731 as well as adding the ``___XR'' suffix to build the name of
6732 the associated renaming symbol. */
6733 char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
6734 /* Function names sometimes contain suffixes used
6735 for instance to qualify nested subprograms. When building
6736 the XR type name, we need to make sure that this suffix is
6737 not included. So do not include any suffix in the function
6738 name length below. */
6739 const int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
6740 const int rename_len = function_name_len + 2 /* "__" */
6741 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 6742
529cad9c
PH
6743 /* Strip the suffix if necessary. */
6744 function_name[function_name_len] = '\0';
6745
4c4b4cd2
PH
6746 /* Library-level functions are a special case, as GNAT adds
6747 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 6748 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
6749 have this prefix, so we need to skip this prefix if present. */
6750 if (function_name_len > 5 /* "_ada_" */
6751 && strstr (function_name, "_ada_") == function_name)
6752 function_name = function_name + 5;
6753
6754 rename = (char *) alloca (rename_len * sizeof (char));
6755 sprintf (rename, "%s__%s___XR", function_name, name);
6756 }
6757 else
6758 {
6759 const int rename_len = strlen (name) + 6;
6760 rename = (char *) alloca (rename_len * sizeof (char));
6761 sprintf (rename, "%s___XR", name);
6762 }
6763
6764 return ada_find_any_symbol (rename);
6765}
6766
14f9c5c9 6767/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 6768 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 6769 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
6770 otherwise return 0. */
6771
14f9c5c9 6772int
d2e4a39e 6773ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
6774{
6775 if (type1 == NULL)
6776 return 1;
6777 else if (type0 == NULL)
6778 return 0;
6779 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
6780 return 1;
6781 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
6782 return 0;
4c4b4cd2
PH
6783 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
6784 return 1;
14f9c5c9
AS
6785 else if (ada_is_packed_array_type (type0))
6786 return 1;
4c4b4cd2
PH
6787 else if (ada_is_array_descriptor_type (type0)
6788 && !ada_is_array_descriptor_type (type1))
14f9c5c9 6789 return 1;
aeb5907d
JB
6790 else
6791 {
6792 const char *type0_name = type_name_no_tag (type0);
6793 const char *type1_name = type_name_no_tag (type1);
6794
6795 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
6796 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
6797 return 1;
6798 }
14f9c5c9
AS
6799 return 0;
6800}
6801
6802/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
6803 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6804
d2e4a39e
AS
6805char *
6806ada_type_name (struct type *type)
14f9c5c9 6807{
d2e4a39e 6808 if (type == NULL)
14f9c5c9
AS
6809 return NULL;
6810 else if (TYPE_NAME (type) != NULL)
6811 return TYPE_NAME (type);
6812 else
6813 return TYPE_TAG_NAME (type);
6814}
6815
6816/* Find a parallel type to TYPE whose name is formed by appending
4c4b4cd2 6817 SUFFIX to the name of TYPE. */
14f9c5c9 6818
d2e4a39e 6819struct type *
ebf56fd3 6820ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 6821{
d2e4a39e 6822 static char *name;
14f9c5c9 6823 static size_t name_len = 0;
14f9c5c9 6824 int len;
d2e4a39e
AS
6825 char *typename = ada_type_name (type);
6826
14f9c5c9
AS
6827 if (typename == NULL)
6828 return NULL;
6829
6830 len = strlen (typename);
6831
d2e4a39e 6832 GROW_VECT (name, name_len, len + strlen (suffix) + 1);
14f9c5c9
AS
6833
6834 strcpy (name, typename);
6835 strcpy (name + len, suffix);
6836
6837 return ada_find_any_type (name);
6838}
6839
6840
6841/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 6842 type describing its fields. Otherwise, return NULL. */
14f9c5c9 6843
d2e4a39e
AS
6844static struct type *
6845dynamic_template_type (struct type *type)
14f9c5c9 6846{
61ee279c 6847 type = ada_check_typedef (type);
14f9c5c9
AS
6848
6849 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 6850 || ada_type_name (type) == NULL)
14f9c5c9 6851 return NULL;
d2e4a39e 6852 else
14f9c5c9
AS
6853 {
6854 int len = strlen (ada_type_name (type));
4c4b4cd2
PH
6855 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
6856 return type;
14f9c5c9 6857 else
4c4b4cd2 6858 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
6859 }
6860}
6861
6862/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 6863 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 6864
d2e4a39e
AS
6865static int
6866is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
6867{
6868 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
d2e4a39e 6869 return name != NULL
14f9c5c9
AS
6870 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
6871 && strstr (name, "___XVL") != NULL;
6872}
6873
4c4b4cd2
PH
6874/* The index of the variant field of TYPE, or -1 if TYPE does not
6875 represent a variant record type. */
14f9c5c9 6876
d2e4a39e 6877static int
4c4b4cd2 6878variant_field_index (struct type *type)
14f9c5c9
AS
6879{
6880 int f;
6881
4c4b4cd2
PH
6882 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6883 return -1;
6884
6885 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
6886 {
6887 if (ada_is_variant_part (type, f))
6888 return f;
6889 }
6890 return -1;
14f9c5c9
AS
6891}
6892
4c4b4cd2
PH
6893/* A record type with no fields. */
6894
d2e4a39e
AS
6895static struct type *
6896empty_record (struct objfile *objfile)
14f9c5c9 6897{
d2e4a39e 6898 struct type *type = alloc_type (objfile);
14f9c5c9
AS
6899 TYPE_CODE (type) = TYPE_CODE_STRUCT;
6900 TYPE_NFIELDS (type) = 0;
6901 TYPE_FIELDS (type) = NULL;
6902 TYPE_NAME (type) = "<empty>";
6903 TYPE_TAG_NAME (type) = NULL;
6904 TYPE_FLAGS (type) = 0;
6905 TYPE_LENGTH (type) = 0;
6906 return type;
6907}
6908
6909/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
6910 the value of type TYPE at VALADDR or ADDRESS (see comments at
6911 the beginning of this section) VAL according to GNAT conventions.
6912 DVAL0 should describe the (portion of a) record that contains any
df407dfe 6913 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
6914 an outer-level type (i.e., as opposed to a branch of a variant.) A
6915 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 6916 of the variant.
14f9c5c9 6917
4c4b4cd2
PH
6918 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6919 length are not statically known are discarded. As a consequence,
6920 VALADDR, ADDRESS and DVAL0 are ignored.
6921
6922 NOTE: Limitations: For now, we assume that dynamic fields and
6923 variants occupy whole numbers of bytes. However, they need not be
6924 byte-aligned. */
6925
6926struct type *
10a2c479 6927ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 6928 const gdb_byte *valaddr,
4c4b4cd2
PH
6929 CORE_ADDR address, struct value *dval0,
6930 int keep_dynamic_fields)
14f9c5c9 6931{
d2e4a39e
AS
6932 struct value *mark = value_mark ();
6933 struct value *dval;
6934 struct type *rtype;
14f9c5c9 6935 int nfields, bit_len;
4c4b4cd2 6936 int variant_field;
14f9c5c9 6937 long off;
4c4b4cd2 6938 int fld_bit_len, bit_incr;
14f9c5c9
AS
6939 int f;
6940
4c4b4cd2
PH
6941 /* Compute the number of fields in this record type that are going
6942 to be processed: unless keep_dynamic_fields, this includes only
6943 fields whose position and length are static will be processed. */
6944 if (keep_dynamic_fields)
6945 nfields = TYPE_NFIELDS (type);
6946 else
6947 {
6948 nfields = 0;
76a01679 6949 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
6950 && !ada_is_variant_part (type, nfields)
6951 && !is_dynamic_field (type, nfields))
6952 nfields++;
6953 }
6954
14f9c5c9
AS
6955 rtype = alloc_type (TYPE_OBJFILE (type));
6956 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6957 INIT_CPLUS_SPECIFIC (rtype);
6958 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 6959 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
6960 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6961 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
6962 TYPE_NAME (rtype) = ada_type_name (type);
6963 TYPE_TAG_NAME (rtype) = NULL;
4c4b4cd2 6964 TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE;
14f9c5c9 6965
d2e4a39e
AS
6966 off = 0;
6967 bit_len = 0;
4c4b4cd2
PH
6968 variant_field = -1;
6969
14f9c5c9
AS
6970 for (f = 0; f < nfields; f += 1)
6971 {
6c038f32
PH
6972 off = align_value (off, field_alignment (type, f))
6973 + TYPE_FIELD_BITPOS (type, f);
14f9c5c9 6974 TYPE_FIELD_BITPOS (rtype, f) = off;
d2e4a39e 6975 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 6976
d2e4a39e 6977 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
6978 {
6979 variant_field = f;
6980 fld_bit_len = bit_incr = 0;
6981 }
14f9c5c9 6982 else if (is_dynamic_field (type, f))
4c4b4cd2
PH
6983 {
6984 if (dval0 == NULL)
6985 dval = value_from_contents_and_address (rtype, valaddr, address);
6986 else
6987 dval = dval0;
6988
1ed6ede0
JB
6989 /* Get the fixed type of the field. Note that, in this case, we
6990 do not want to get the real type out of the tag: if the current
6991 field is the parent part of a tagged record, we will get the
6992 tag of the object. Clearly wrong: the real type of the parent
6993 is not the real type of the child. We would end up in an infinite
6994 loop. */
4c4b4cd2
PH
6995 TYPE_FIELD_TYPE (rtype, f) =
6996 ada_to_fixed_type
6997 (ada_get_base_type
6998 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f))),
6999 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
1ed6ede0 7000 cond_offset_target (address, off / TARGET_CHAR_BIT), dval, 0);
4c4b4cd2
PH
7001 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7002 bit_incr = fld_bit_len =
7003 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
7004 }
14f9c5c9 7005 else
4c4b4cd2
PH
7006 {
7007 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
7008 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7009 if (TYPE_FIELD_BITSIZE (type, f) > 0)
7010 bit_incr = fld_bit_len =
7011 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7012 else
7013 bit_incr = fld_bit_len =
7014 TYPE_LENGTH (TYPE_FIELD_TYPE (type, f)) * TARGET_CHAR_BIT;
7015 }
14f9c5c9 7016 if (off + fld_bit_len > bit_len)
4c4b4cd2 7017 bit_len = off + fld_bit_len;
14f9c5c9 7018 off += bit_incr;
4c4b4cd2
PH
7019 TYPE_LENGTH (rtype) =
7020 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 7021 }
4c4b4cd2
PH
7022
7023 /* We handle the variant part, if any, at the end because of certain
7024 odd cases in which it is re-ordered so as NOT the last field of
7025 the record. This can happen in the presence of representation
7026 clauses. */
7027 if (variant_field >= 0)
7028 {
7029 struct type *branch_type;
7030
7031 off = TYPE_FIELD_BITPOS (rtype, variant_field);
7032
7033 if (dval0 == NULL)
7034 dval = value_from_contents_and_address (rtype, valaddr, address);
7035 else
7036 dval = dval0;
7037
7038 branch_type =
7039 to_fixed_variant_branch_type
7040 (TYPE_FIELD_TYPE (type, variant_field),
7041 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7042 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7043 if (branch_type == NULL)
7044 {
7045 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
7046 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7047 TYPE_NFIELDS (rtype) -= 1;
7048 }
7049 else
7050 {
7051 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7052 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7053 fld_bit_len =
7054 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
7055 TARGET_CHAR_BIT;
7056 if (off + fld_bit_len > bit_len)
7057 bit_len = off + fld_bit_len;
7058 TYPE_LENGTH (rtype) =
7059 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7060 }
7061 }
7062
714e53ab
PH
7063 /* According to exp_dbug.ads, the size of TYPE for variable-size records
7064 should contain the alignment of that record, which should be a strictly
7065 positive value. If null or negative, then something is wrong, most
7066 probably in the debug info. In that case, we don't round up the size
7067 of the resulting type. If this record is not part of another structure,
7068 the current RTYPE length might be good enough for our purposes. */
7069 if (TYPE_LENGTH (type) <= 0)
7070 {
323e0a4a
AC
7071 if (TYPE_NAME (rtype))
7072 warning (_("Invalid type size for `%s' detected: %d."),
7073 TYPE_NAME (rtype), TYPE_LENGTH (type));
7074 else
7075 warning (_("Invalid type size for <unnamed> detected: %d."),
7076 TYPE_LENGTH (type));
714e53ab
PH
7077 }
7078 else
7079 {
7080 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
7081 TYPE_LENGTH (type));
7082 }
14f9c5c9
AS
7083
7084 value_free_to_mark (mark);
d2e4a39e 7085 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 7086 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
7087 return rtype;
7088}
7089
4c4b4cd2
PH
7090/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7091 of 1. */
14f9c5c9 7092
d2e4a39e 7093static struct type *
fc1a4b47 7094template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
7095 CORE_ADDR address, struct value *dval0)
7096{
7097 return ada_template_to_fixed_record_type_1 (type, valaddr,
7098 address, dval0, 1);
7099}
7100
7101/* An ordinary record type in which ___XVL-convention fields and
7102 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7103 static approximations, containing all possible fields. Uses
7104 no runtime values. Useless for use in values, but that's OK,
7105 since the results are used only for type determinations. Works on both
7106 structs and unions. Representation note: to save space, we memorize
7107 the result of this function in the TYPE_TARGET_TYPE of the
7108 template type. */
7109
7110static struct type *
7111template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
7112{
7113 struct type *type;
7114 int nfields;
7115 int f;
7116
4c4b4cd2
PH
7117 if (TYPE_TARGET_TYPE (type0) != NULL)
7118 return TYPE_TARGET_TYPE (type0);
7119
7120 nfields = TYPE_NFIELDS (type0);
7121 type = type0;
14f9c5c9
AS
7122
7123 for (f = 0; f < nfields; f += 1)
7124 {
61ee279c 7125 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
4c4b4cd2 7126 struct type *new_type;
14f9c5c9 7127
4c4b4cd2
PH
7128 if (is_dynamic_field (type0, f))
7129 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
14f9c5c9 7130 else
f192137b 7131 new_type = static_unwrap_type (field_type);
4c4b4cd2
PH
7132 if (type == type0 && new_type != field_type)
7133 {
7134 TYPE_TARGET_TYPE (type0) = type = alloc_type (TYPE_OBJFILE (type0));
7135 TYPE_CODE (type) = TYPE_CODE (type0);
7136 INIT_CPLUS_SPECIFIC (type);
7137 TYPE_NFIELDS (type) = nfields;
7138 TYPE_FIELDS (type) = (struct field *)
7139 TYPE_ALLOC (type, nfields * sizeof (struct field));
7140 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
7141 sizeof (struct field) * nfields);
7142 TYPE_NAME (type) = ada_type_name (type0);
7143 TYPE_TAG_NAME (type) = NULL;
7144 TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE;
7145 TYPE_LENGTH (type) = 0;
7146 }
7147 TYPE_FIELD_TYPE (type, f) = new_type;
7148 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
14f9c5c9 7149 }
14f9c5c9
AS
7150 return type;
7151}
7152
4c4b4cd2
PH
7153/* Given an object of type TYPE whose contents are at VALADDR and
7154 whose address in memory is ADDRESS, returns a revision of TYPE --
7155 a non-dynamic-sized record with a variant part -- in which
7156 the variant part is replaced with the appropriate branch. Looks
7157 for discriminant values in DVAL0, which can be NULL if the record
7158 contains the necessary discriminant values. */
7159
d2e4a39e 7160static struct type *
fc1a4b47 7161to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 7162 CORE_ADDR address, struct value *dval0)
14f9c5c9 7163{
d2e4a39e 7164 struct value *mark = value_mark ();
4c4b4cd2 7165 struct value *dval;
d2e4a39e 7166 struct type *rtype;
14f9c5c9
AS
7167 struct type *branch_type;
7168 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 7169 int variant_field = variant_field_index (type);
14f9c5c9 7170
4c4b4cd2 7171 if (variant_field == -1)
14f9c5c9
AS
7172 return type;
7173
4c4b4cd2
PH
7174 if (dval0 == NULL)
7175 dval = value_from_contents_and_address (type, valaddr, address);
7176 else
7177 dval = dval0;
7178
14f9c5c9
AS
7179 rtype = alloc_type (TYPE_OBJFILE (type));
7180 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
7181 INIT_CPLUS_SPECIFIC (rtype);
7182 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
7183 TYPE_FIELDS (rtype) =
7184 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7185 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 7186 sizeof (struct field) * nfields);
14f9c5c9
AS
7187 TYPE_NAME (rtype) = ada_type_name (type);
7188 TYPE_TAG_NAME (rtype) = NULL;
4c4b4cd2 7189 TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE;
14f9c5c9
AS
7190 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7191
4c4b4cd2
PH
7192 branch_type = to_fixed_variant_branch_type
7193 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 7194 cond_offset_host (valaddr,
4c4b4cd2
PH
7195 TYPE_FIELD_BITPOS (type, variant_field)
7196 / TARGET_CHAR_BIT),
d2e4a39e 7197 cond_offset_target (address,
4c4b4cd2
PH
7198 TYPE_FIELD_BITPOS (type, variant_field)
7199 / TARGET_CHAR_BIT), dval);
d2e4a39e 7200 if (branch_type == NULL)
14f9c5c9 7201 {
4c4b4cd2
PH
7202 int f;
7203 for (f = variant_field + 1; f < nfields; f += 1)
7204 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 7205 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
7206 }
7207 else
7208 {
4c4b4cd2
PH
7209 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7210 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7211 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 7212 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 7213 }
4c4b4cd2 7214 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 7215
4c4b4cd2 7216 value_free_to_mark (mark);
14f9c5c9
AS
7217 return rtype;
7218}
7219
7220/* An ordinary record type (with fixed-length fields) that describes
7221 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7222 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
7223 should be in DVAL, a record value; it may be NULL if the object
7224 at ADDR itself contains any necessary discriminant values.
7225 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7226 values from the record are needed. Except in the case that DVAL,
7227 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7228 unchecked) is replaced by a particular branch of the variant.
7229
7230 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7231 is questionable and may be removed. It can arise during the
7232 processing of an unconstrained-array-of-record type where all the
7233 variant branches have exactly the same size. This is because in
7234 such cases, the compiler does not bother to use the XVS convention
7235 when encoding the record. I am currently dubious of this
7236 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 7237
d2e4a39e 7238static struct type *
fc1a4b47 7239to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 7240 CORE_ADDR address, struct value *dval)
14f9c5c9 7241{
d2e4a39e 7242 struct type *templ_type;
14f9c5c9 7243
4c4b4cd2
PH
7244 if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
7245 return type0;
7246
d2e4a39e 7247 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
7248
7249 if (templ_type != NULL)
7250 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
7251 else if (variant_field_index (type0) >= 0)
7252 {
7253 if (dval == NULL && valaddr == NULL && address == 0)
7254 return type0;
7255 return to_record_with_fixed_variant_part (type0, valaddr, address,
7256 dval);
7257 }
14f9c5c9
AS
7258 else
7259 {
4c4b4cd2 7260 TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE;
14f9c5c9
AS
7261 return type0;
7262 }
7263
7264}
7265
7266/* An ordinary record type (with fixed-length fields) that describes
7267 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7268 union type. Any necessary discriminants' values should be in DVAL,
7269 a record value. That is, this routine selects the appropriate
7270 branch of the union at ADDR according to the discriminant value
4c4b4cd2 7271 indicated in the union's type name. */
14f9c5c9 7272
d2e4a39e 7273static struct type *
fc1a4b47 7274to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 7275 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
7276{
7277 int which;
d2e4a39e
AS
7278 struct type *templ_type;
7279 struct type *var_type;
14f9c5c9
AS
7280
7281 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
7282 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 7283 else
14f9c5c9
AS
7284 var_type = var_type0;
7285
7286 templ_type = ada_find_parallel_type (var_type, "___XVU");
7287
7288 if (templ_type != NULL)
7289 var_type = templ_type;
7290
d2e4a39e
AS
7291 which =
7292 ada_which_variant_applies (var_type,
0fd88904 7293 value_type (dval), value_contents (dval));
14f9c5c9
AS
7294
7295 if (which < 0)
7296 return empty_record (TYPE_OBJFILE (var_type));
7297 else if (is_dynamic_field (var_type, which))
4c4b4cd2 7298 return to_fixed_record_type
d2e4a39e
AS
7299 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
7300 valaddr, address, dval);
4c4b4cd2 7301 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
7302 return
7303 to_fixed_record_type
7304 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
7305 else
7306 return TYPE_FIELD_TYPE (var_type, which);
7307}
7308
7309/* Assuming that TYPE0 is an array type describing the type of a value
7310 at ADDR, and that DVAL describes a record containing any
7311 discriminants used in TYPE0, returns a type for the value that
7312 contains no dynamic components (that is, no components whose sizes
7313 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7314 true, gives an error message if the resulting type's size is over
4c4b4cd2 7315 varsize_limit. */
14f9c5c9 7316
d2e4a39e
AS
7317static struct type *
7318to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 7319 int ignore_too_big)
14f9c5c9 7320{
d2e4a39e
AS
7321 struct type *index_type_desc;
7322 struct type *result;
14f9c5c9 7323
4c4b4cd2
PH
7324 if (ada_is_packed_array_type (type0) /* revisit? */
7325 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
7326 return type0;
14f9c5c9
AS
7327
7328 index_type_desc = ada_find_parallel_type (type0, "___XA");
7329 if (index_type_desc == NULL)
7330 {
61ee279c 7331 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
14f9c5c9 7332 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
7333 depend on the contents of the array in properly constructed
7334 debugging data. */
529cad9c
PH
7335 /* Create a fixed version of the array element type.
7336 We're not providing the address of an element here,
e1d5a0d2 7337 and thus the actual object value cannot be inspected to do
529cad9c
PH
7338 the conversion. This should not be a problem, since arrays of
7339 unconstrained objects are not allowed. In particular, all
7340 the elements of an array of a tagged type should all be of
7341 the same type specified in the debugging info. No need to
7342 consult the object tag. */
1ed6ede0 7343 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9
AS
7344
7345 if (elt_type0 == elt_type)
4c4b4cd2 7346 result = type0;
14f9c5c9 7347 else
4c4b4cd2
PH
7348 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
7349 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
7350 }
7351 else
7352 {
7353 int i;
7354 struct type *elt_type0;
7355
7356 elt_type0 = type0;
7357 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 7358 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
7359
7360 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
7361 depend on the contents of the array in properly constructed
7362 debugging data. */
529cad9c
PH
7363 /* Create a fixed version of the array element type.
7364 We're not providing the address of an element here,
e1d5a0d2 7365 and thus the actual object value cannot be inspected to do
529cad9c
PH
7366 the conversion. This should not be a problem, since arrays of
7367 unconstrained objects are not allowed. In particular, all
7368 the elements of an array of a tagged type should all be of
7369 the same type specified in the debugging info. No need to
7370 consult the object tag. */
1ed6ede0
JB
7371 result =
7372 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
14f9c5c9 7373 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
7374 {
7375 struct type *range_type =
7376 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, i),
7377 dval, TYPE_OBJFILE (type0));
7378 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
7379 result, range_type);
7380 }
d2e4a39e 7381 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 7382 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
7383 }
7384
4c4b4cd2 7385 TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE;
14f9c5c9 7386 return result;
d2e4a39e 7387}
14f9c5c9
AS
7388
7389
7390/* A standard type (containing no dynamically sized components)
7391 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7392 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 7393 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
7394 ADDRESS or in VALADDR contains these discriminants.
7395
1ed6ede0
JB
7396 If CHECK_TAG is not null, in the case of tagged types, this function
7397 attempts to locate the object's tag and use it to compute the actual
7398 type. However, when ADDRESS is null, we cannot use it to determine the
7399 location of the tag, and therefore compute the tagged type's actual type.
7400 So we return the tagged type without consulting the tag. */
529cad9c 7401
f192137b
JB
7402static struct type *
7403ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 7404 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 7405{
61ee279c 7406 type = ada_check_typedef (type);
d2e4a39e
AS
7407 switch (TYPE_CODE (type))
7408 {
7409 default:
14f9c5c9 7410 return type;
d2e4a39e 7411 case TYPE_CODE_STRUCT:
4c4b4cd2 7412 {
76a01679 7413 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
7414 struct type *fixed_record_type =
7415 to_fixed_record_type (type, valaddr, address, NULL);
529cad9c
PH
7416 /* If STATIC_TYPE is a tagged type and we know the object's address,
7417 then we can determine its tag, and compute the object's actual
1ed6ede0
JB
7418 type from there. Note that we have to use the fixed record
7419 type (the parent part of the record may have dynamic fields
7420 and the way the location of _tag is expressed may depend on
7421 them). */
529cad9c 7422
1ed6ede0 7423 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679
JB
7424 {
7425 struct type *real_type =
1ed6ede0
JB
7426 type_from_tag (value_tag_from_contents_and_address
7427 (fixed_record_type,
7428 valaddr,
7429 address));
76a01679 7430 if (real_type != NULL)
1ed6ede0 7431 return to_fixed_record_type (real_type, valaddr, address, NULL);
76a01679 7432 }
1ed6ede0 7433 return fixed_record_type;
4c4b4cd2 7434 }
d2e4a39e 7435 case TYPE_CODE_ARRAY:
4c4b4cd2 7436 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
7437 case TYPE_CODE_UNION:
7438 if (dval == NULL)
4c4b4cd2 7439 return type;
d2e4a39e 7440 else
4c4b4cd2 7441 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 7442 }
14f9c5c9
AS
7443}
7444
f192137b
JB
7445/* The same as ada_to_fixed_type_1, except that it preserves the type
7446 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
7447 ada_to_fixed_type_1 would return the type referenced by TYPE. */
7448
7449struct type *
7450ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
7451 CORE_ADDR address, struct value *dval, int check_tag)
7452
7453{
7454 struct type *fixed_type =
7455 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
7456
7457 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
7458 && TYPE_TARGET_TYPE (type) == fixed_type)
7459 return type;
7460
7461 return fixed_type;
7462}
7463
14f9c5c9 7464/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 7465 TYPE0, but based on no runtime data. */
14f9c5c9 7466
d2e4a39e
AS
7467static struct type *
7468to_static_fixed_type (struct type *type0)
14f9c5c9 7469{
d2e4a39e 7470 struct type *type;
14f9c5c9
AS
7471
7472 if (type0 == NULL)
7473 return NULL;
7474
4c4b4cd2
PH
7475 if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
7476 return type0;
7477
61ee279c 7478 type0 = ada_check_typedef (type0);
d2e4a39e 7479
14f9c5c9
AS
7480 switch (TYPE_CODE (type0))
7481 {
7482 default:
7483 return type0;
7484 case TYPE_CODE_STRUCT:
7485 type = dynamic_template_type (type0);
d2e4a39e 7486 if (type != NULL)
4c4b4cd2
PH
7487 return template_to_static_fixed_type (type);
7488 else
7489 return template_to_static_fixed_type (type0);
14f9c5c9
AS
7490 case TYPE_CODE_UNION:
7491 type = ada_find_parallel_type (type0, "___XVU");
7492 if (type != NULL)
4c4b4cd2
PH
7493 return template_to_static_fixed_type (type);
7494 else
7495 return template_to_static_fixed_type (type0);
14f9c5c9
AS
7496 }
7497}
7498
4c4b4cd2
PH
7499/* A static approximation of TYPE with all type wrappers removed. */
7500
d2e4a39e
AS
7501static struct type *
7502static_unwrap_type (struct type *type)
14f9c5c9
AS
7503{
7504 if (ada_is_aligner_type (type))
7505 {
61ee279c 7506 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 7507 if (ada_type_name (type1) == NULL)
4c4b4cd2 7508 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
7509
7510 return static_unwrap_type (type1);
7511 }
d2e4a39e 7512 else
14f9c5c9 7513 {
d2e4a39e
AS
7514 struct type *raw_real_type = ada_get_base_type (type);
7515 if (raw_real_type == type)
4c4b4cd2 7516 return type;
14f9c5c9 7517 else
4c4b4cd2 7518 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
7519 }
7520}
7521
7522/* In some cases, incomplete and private types require
4c4b4cd2 7523 cross-references that are not resolved as records (for example,
14f9c5c9
AS
7524 type Foo;
7525 type FooP is access Foo;
7526 V: FooP;
7527 type Foo is array ...;
4c4b4cd2 7528 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
7529 cross-references to such types, we instead substitute for FooP a
7530 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 7531 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
7532
7533/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
7534 exists, otherwise TYPE. */
7535
d2e4a39e 7536struct type *
61ee279c 7537ada_check_typedef (struct type *type)
14f9c5c9 7538{
727e3d2e
JB
7539 if (type == NULL)
7540 return NULL;
7541
14f9c5c9
AS
7542 CHECK_TYPEDEF (type);
7543 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 7544 || !TYPE_STUB (type)
14f9c5c9
AS
7545 || TYPE_TAG_NAME (type) == NULL)
7546 return type;
d2e4a39e 7547 else
14f9c5c9 7548 {
d2e4a39e
AS
7549 char *name = TYPE_TAG_NAME (type);
7550 struct type *type1 = ada_find_any_type (name);
14f9c5c9
AS
7551 return (type1 == NULL) ? type : type1;
7552 }
7553}
7554
7555/* A value representing the data at VALADDR/ADDRESS as described by
7556 type TYPE0, but with a standard (static-sized) type that correctly
7557 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7558 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 7559 creation of struct values]. */
14f9c5c9 7560
4c4b4cd2
PH
7561static struct value *
7562ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
7563 struct value *val0)
14f9c5c9 7564{
1ed6ede0 7565 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
14f9c5c9
AS
7566 if (type == type0 && val0 != NULL)
7567 return val0;
d2e4a39e 7568 else
4c4b4cd2
PH
7569 return value_from_contents_and_address (type, 0, address);
7570}
7571
7572/* A value representing VAL, but with a standard (static-sized) type
7573 that correctly describes it. Does not necessarily create a new
7574 value. */
7575
7576static struct value *
7577ada_to_fixed_value (struct value *val)
7578{
df407dfe
AC
7579 return ada_to_fixed_value_create (value_type (val),
7580 VALUE_ADDRESS (val) + value_offset (val),
4c4b4cd2 7581 val);
14f9c5c9
AS
7582}
7583
4c4b4cd2 7584/* A value representing VAL, but with a standard (static-sized) type
14f9c5c9
AS
7585 chosen to approximate the real type of VAL as well as possible, but
7586 without consulting any runtime values. For Ada dynamic-sized
4c4b4cd2 7587 types, therefore, the type of the result is likely to be inaccurate. */
14f9c5c9 7588
d2e4a39e
AS
7589struct value *
7590ada_to_static_fixed_value (struct value *val)
14f9c5c9 7591{
d2e4a39e 7592 struct type *type =
df407dfe
AC
7593 to_static_fixed_type (static_unwrap_type (value_type (val)));
7594 if (type == value_type (val))
14f9c5c9
AS
7595 return val;
7596 else
4c4b4cd2 7597 return coerce_unspec_val_to_type (val, type);
14f9c5c9 7598}
d2e4a39e 7599\f
14f9c5c9 7600
14f9c5c9
AS
7601/* Attributes */
7602
4c4b4cd2
PH
7603/* Table mapping attribute numbers to names.
7604 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 7605
d2e4a39e 7606static const char *attribute_names[] = {
14f9c5c9
AS
7607 "<?>",
7608
d2e4a39e 7609 "first",
14f9c5c9
AS
7610 "last",
7611 "length",
7612 "image",
14f9c5c9
AS
7613 "max",
7614 "min",
4c4b4cd2
PH
7615 "modulus",
7616 "pos",
7617 "size",
7618 "tag",
14f9c5c9 7619 "val",
14f9c5c9
AS
7620 0
7621};
7622
d2e4a39e 7623const char *
4c4b4cd2 7624ada_attribute_name (enum exp_opcode n)
14f9c5c9 7625{
4c4b4cd2
PH
7626 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
7627 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
7628 else
7629 return attribute_names[0];
7630}
7631
4c4b4cd2 7632/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 7633
4c4b4cd2
PH
7634static LONGEST
7635pos_atr (struct value *arg)
14f9c5c9 7636{
df407dfe 7637 struct type *type = value_type (arg);
14f9c5c9 7638
d2e4a39e 7639 if (!discrete_type_p (type))
323e0a4a 7640 error (_("'POS only defined on discrete types"));
14f9c5c9
AS
7641
7642 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7643 {
7644 int i;
7645 LONGEST v = value_as_long (arg);
7646
d2e4a39e 7647 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
7648 {
7649 if (v == TYPE_FIELD_BITPOS (type, i))
7650 return i;
7651 }
323e0a4a 7652 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9
AS
7653 }
7654 else
4c4b4cd2
PH
7655 return value_as_long (arg);
7656}
7657
7658static struct value *
7659value_pos_atr (struct value *arg)
7660{
72d5681a 7661 return value_from_longest (builtin_type_int, pos_atr (arg));
14f9c5c9
AS
7662}
7663
4c4b4cd2 7664/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 7665
d2e4a39e
AS
7666static struct value *
7667value_val_atr (struct type *type, struct value *arg)
14f9c5c9 7668{
d2e4a39e 7669 if (!discrete_type_p (type))
323e0a4a 7670 error (_("'VAL only defined on discrete types"));
df407dfe 7671 if (!integer_type_p (value_type (arg)))
323e0a4a 7672 error (_("'VAL requires integral argument"));
14f9c5c9
AS
7673
7674 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7675 {
7676 long pos = value_as_long (arg);
7677 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 7678 error (_("argument to 'VAL out of range"));
d2e4a39e 7679 return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
14f9c5c9
AS
7680 }
7681 else
7682 return value_from_longest (type, value_as_long (arg));
7683}
14f9c5c9 7684\f
d2e4a39e 7685
4c4b4cd2 7686 /* Evaluation */
14f9c5c9 7687
4c4b4cd2
PH
7688/* True if TYPE appears to be an Ada character type.
7689 [At the moment, this is true only for Character and Wide_Character;
7690 It is a heuristic test that could stand improvement]. */
14f9c5c9 7691
d2e4a39e
AS
7692int
7693ada_is_character_type (struct type *type)
14f9c5c9 7694{
7b9f71f2
JB
7695 const char *name;
7696
7697 /* If the type code says it's a character, then assume it really is,
7698 and don't check any further. */
7699 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
7700 return 1;
7701
7702 /* Otherwise, assume it's a character type iff it is a discrete type
7703 with a known character type name. */
7704 name = ada_type_name (type);
7705 return (name != NULL
7706 && (TYPE_CODE (type) == TYPE_CODE_INT
7707 || TYPE_CODE (type) == TYPE_CODE_RANGE)
7708 && (strcmp (name, "character") == 0
7709 || strcmp (name, "wide_character") == 0
5a517ebd 7710 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 7711 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
7712}
7713
4c4b4cd2 7714/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
7715
7716int
ebf56fd3 7717ada_is_string_type (struct type *type)
14f9c5c9 7718{
61ee279c 7719 type = ada_check_typedef (type);
d2e4a39e 7720 if (type != NULL
14f9c5c9 7721 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
7722 && (ada_is_simple_array_type (type)
7723 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
7724 && ada_array_arity (type) == 1)
7725 {
7726 struct type *elttype = ada_array_element_type (type, 1);
7727
7728 return ada_is_character_type (elttype);
7729 }
d2e4a39e 7730 else
14f9c5c9
AS
7731 return 0;
7732}
7733
7734
7735/* True if TYPE is a struct type introduced by the compiler to force the
7736 alignment of a value. Such types have a single field with a
4c4b4cd2 7737 distinctive name. */
14f9c5c9
AS
7738
7739int
ebf56fd3 7740ada_is_aligner_type (struct type *type)
14f9c5c9 7741{
61ee279c 7742 type = ada_check_typedef (type);
714e53ab
PH
7743
7744 /* If we can find a parallel XVS type, then the XVS type should
7745 be used instead of this type. And hence, this is not an aligner
7746 type. */
7747 if (ada_find_parallel_type (type, "___XVS") != NULL)
7748 return 0;
7749
14f9c5c9 7750 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
7751 && TYPE_NFIELDS (type) == 1
7752 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
7753}
7754
7755/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 7756 the parallel type. */
14f9c5c9 7757
d2e4a39e
AS
7758struct type *
7759ada_get_base_type (struct type *raw_type)
14f9c5c9 7760{
d2e4a39e
AS
7761 struct type *real_type_namer;
7762 struct type *raw_real_type;
14f9c5c9
AS
7763
7764 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
7765 return raw_type;
7766
7767 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 7768 if (real_type_namer == NULL
14f9c5c9
AS
7769 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
7770 || TYPE_NFIELDS (real_type_namer) != 1)
7771 return raw_type;
7772
7773 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
d2e4a39e 7774 if (raw_real_type == NULL)
14f9c5c9
AS
7775 return raw_type;
7776 else
7777 return raw_real_type;
d2e4a39e 7778}
14f9c5c9 7779
4c4b4cd2 7780/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 7781
d2e4a39e
AS
7782struct type *
7783ada_aligned_type (struct type *type)
14f9c5c9
AS
7784{
7785 if (ada_is_aligner_type (type))
7786 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
7787 else
7788 return ada_get_base_type (type);
7789}
7790
7791
7792/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 7793 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 7794
fc1a4b47
AC
7795const gdb_byte *
7796ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 7797{
d2e4a39e 7798 if (ada_is_aligner_type (type))
14f9c5c9 7799 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
7800 valaddr +
7801 TYPE_FIELD_BITPOS (type,
7802 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
7803 else
7804 return valaddr;
7805}
7806
4c4b4cd2
PH
7807
7808
14f9c5c9 7809/* The printed representation of an enumeration literal with encoded
4c4b4cd2 7810 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
7811const char *
7812ada_enum_name (const char *name)
14f9c5c9 7813{
4c4b4cd2
PH
7814 static char *result;
7815 static size_t result_len = 0;
d2e4a39e 7816 char *tmp;
14f9c5c9 7817
4c4b4cd2
PH
7818 /* First, unqualify the enumeration name:
7819 1. Search for the last '.' character. If we find one, then skip
76a01679
JB
7820 all the preceeding characters, the unqualified name starts
7821 right after that dot.
4c4b4cd2 7822 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
7823 translates dots into "__". Search forward for double underscores,
7824 but stop searching when we hit an overloading suffix, which is
7825 of the form "__" followed by digits. */
4c4b4cd2 7826
c3e5cd34
PH
7827 tmp = strrchr (name, '.');
7828 if (tmp != NULL)
4c4b4cd2
PH
7829 name = tmp + 1;
7830 else
14f9c5c9 7831 {
4c4b4cd2
PH
7832 while ((tmp = strstr (name, "__")) != NULL)
7833 {
7834 if (isdigit (tmp[2]))
7835 break;
7836 else
7837 name = tmp + 2;
7838 }
14f9c5c9
AS
7839 }
7840
7841 if (name[0] == 'Q')
7842 {
14f9c5c9
AS
7843 int v;
7844 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
7845 {
7846 if (sscanf (name + 2, "%x", &v) != 1)
7847 return name;
7848 }
14f9c5c9 7849 else
4c4b4cd2 7850 return name;
14f9c5c9 7851
4c4b4cd2 7852 GROW_VECT (result, result_len, 16);
14f9c5c9 7853 if (isascii (v) && isprint (v))
4c4b4cd2 7854 sprintf (result, "'%c'", v);
14f9c5c9 7855 else if (name[1] == 'U')
4c4b4cd2 7856 sprintf (result, "[\"%02x\"]", v);
14f9c5c9 7857 else
4c4b4cd2 7858 sprintf (result, "[\"%04x\"]", v);
14f9c5c9
AS
7859
7860 return result;
7861 }
d2e4a39e 7862 else
4c4b4cd2 7863 {
c3e5cd34
PH
7864 tmp = strstr (name, "__");
7865 if (tmp == NULL)
7866 tmp = strstr (name, "$");
7867 if (tmp != NULL)
4c4b4cd2
PH
7868 {
7869 GROW_VECT (result, result_len, tmp - name + 1);
7870 strncpy (result, name, tmp - name);
7871 result[tmp - name] = '\0';
7872 return result;
7873 }
7874
7875 return name;
7876 }
14f9c5c9
AS
7877}
7878
d2e4a39e 7879static struct value *
ebf56fd3 7880evaluate_subexp (struct type *expect_type, struct expression *exp, int *pos,
4c4b4cd2 7881 enum noside noside)
14f9c5c9 7882{
76a01679 7883 return (*exp->language_defn->la_exp_desc->evaluate_exp)
4c4b4cd2 7884 (expect_type, exp, pos, noside);
14f9c5c9
AS
7885}
7886
7887/* Evaluate the subexpression of EXP starting at *POS as for
7888 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 7889 expression. */
14f9c5c9 7890
d2e4a39e
AS
7891static struct value *
7892evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 7893{
4c4b4cd2 7894 return (*exp->language_defn->la_exp_desc->evaluate_exp)
14f9c5c9
AS
7895 (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
7896}
7897
7898/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 7899 value it wraps. */
14f9c5c9 7900
d2e4a39e
AS
7901static struct value *
7902unwrap_value (struct value *val)
14f9c5c9 7903{
df407dfe 7904 struct type *type = ada_check_typedef (value_type (val));
14f9c5c9
AS
7905 if (ada_is_aligner_type (type))
7906 {
de4d072f 7907 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 7908 struct type *val_type = ada_check_typedef (value_type (v));
14f9c5c9 7909 if (ada_type_name (val_type) == NULL)
4c4b4cd2 7910 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
7911
7912 return unwrap_value (v);
7913 }
d2e4a39e 7914 else
14f9c5c9 7915 {
d2e4a39e 7916 struct type *raw_real_type =
61ee279c 7917 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 7918
14f9c5c9 7919 if (type == raw_real_type)
4c4b4cd2 7920 return val;
14f9c5c9 7921
d2e4a39e 7922 return
4c4b4cd2
PH
7923 coerce_unspec_val_to_type
7924 (val, ada_to_fixed_type (raw_real_type, 0,
df407dfe 7925 VALUE_ADDRESS (val) + value_offset (val),
1ed6ede0 7926 NULL, 1));
14f9c5c9
AS
7927 }
7928}
d2e4a39e
AS
7929
7930static struct value *
7931cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
7932{
7933 LONGEST val;
7934
df407dfe 7935 if (type == value_type (arg))
14f9c5c9 7936 return arg;
df407dfe 7937 else if (ada_is_fixed_point_type (value_type (arg)))
d2e4a39e 7938 val = ada_float_to_fixed (type,
df407dfe 7939 ada_fixed_to_float (value_type (arg),
4c4b4cd2 7940 value_as_long (arg)));
d2e4a39e 7941 else
14f9c5c9 7942 {
d2e4a39e 7943 DOUBLEST argd =
4c4b4cd2 7944 value_as_double (value_cast (builtin_type_double, value_copy (arg)));
14f9c5c9
AS
7945 val = ada_float_to_fixed (type, argd);
7946 }
7947
7948 return value_from_longest (type, val);
7949}
7950
d2e4a39e
AS
7951static struct value *
7952cast_from_fixed_to_double (struct value *arg)
14f9c5c9 7953{
df407dfe 7954 DOUBLEST val = ada_fixed_to_float (value_type (arg),
4c4b4cd2 7955 value_as_long (arg));
14f9c5c9
AS
7956 return value_from_double (builtin_type_double, val);
7957}
7958
4c4b4cd2
PH
7959/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7960 return the converted value. */
7961
d2e4a39e
AS
7962static struct value *
7963coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 7964{
df407dfe 7965 struct type *type2 = value_type (val);
14f9c5c9
AS
7966 if (type == type2)
7967 return val;
7968
61ee279c
PH
7969 type2 = ada_check_typedef (type2);
7970 type = ada_check_typedef (type);
14f9c5c9 7971
d2e4a39e
AS
7972 if (TYPE_CODE (type2) == TYPE_CODE_PTR
7973 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
7974 {
7975 val = ada_value_ind (val);
df407dfe 7976 type2 = value_type (val);
14f9c5c9
AS
7977 }
7978
d2e4a39e 7979 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
7980 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7981 {
7982 if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
4c4b4cd2
PH
7983 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
7984 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
323e0a4a 7985 error (_("Incompatible types in assignment"));
04624583 7986 deprecated_set_value_type (val, type);
14f9c5c9 7987 }
d2e4a39e 7988 return val;
14f9c5c9
AS
7989}
7990
4c4b4cd2
PH
7991static struct value *
7992ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
7993{
7994 struct value *val;
7995 struct type *type1, *type2;
7996 LONGEST v, v1, v2;
7997
994b9211
AC
7998 arg1 = coerce_ref (arg1);
7999 arg2 = coerce_ref (arg2);
df407dfe
AC
8000 type1 = base_type (ada_check_typedef (value_type (arg1)));
8001 type2 = base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 8002
76a01679
JB
8003 if (TYPE_CODE (type1) != TYPE_CODE_INT
8004 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
8005 return value_binop (arg1, arg2, op);
8006
76a01679 8007 switch (op)
4c4b4cd2
PH
8008 {
8009 case BINOP_MOD:
8010 case BINOP_DIV:
8011 case BINOP_REM:
8012 break;
8013 default:
8014 return value_binop (arg1, arg2, op);
8015 }
8016
8017 v2 = value_as_long (arg2);
8018 if (v2 == 0)
323e0a4a 8019 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
8020
8021 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
8022 return value_binop (arg1, arg2, op);
8023
8024 v1 = value_as_long (arg1);
8025 switch (op)
8026 {
8027 case BINOP_DIV:
8028 v = v1 / v2;
76a01679
JB
8029 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
8030 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
8031 break;
8032 case BINOP_REM:
8033 v = v1 % v2;
76a01679
JB
8034 if (v * v1 < 0)
8035 v -= v2;
4c4b4cd2
PH
8036 break;
8037 default:
8038 /* Should not reach this point. */
8039 v = 0;
8040 }
8041
8042 val = allocate_value (type1);
990a07ab 8043 store_unsigned_integer (value_contents_raw (val),
df407dfe 8044 TYPE_LENGTH (value_type (val)), v);
4c4b4cd2
PH
8045 return val;
8046}
8047
8048static int
8049ada_value_equal (struct value *arg1, struct value *arg2)
8050{
df407dfe
AC
8051 if (ada_is_direct_array_type (value_type (arg1))
8052 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 8053 {
f58b38bf
JB
8054 /* Automatically dereference any array reference before
8055 we attempt to perform the comparison. */
8056 arg1 = ada_coerce_ref (arg1);
8057 arg2 = ada_coerce_ref (arg2);
8058
4c4b4cd2
PH
8059 arg1 = ada_coerce_to_simple_array (arg1);
8060 arg2 = ada_coerce_to_simple_array (arg2);
df407dfe
AC
8061 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
8062 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
323e0a4a 8063 error (_("Attempt to compare array with non-array"));
4c4b4cd2 8064 /* FIXME: The following works only for types whose
76a01679
JB
8065 representations use all bits (no padding or undefined bits)
8066 and do not have user-defined equality. */
8067 return
df407dfe 8068 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
0fd88904 8069 && memcmp (value_contents (arg1), value_contents (arg2),
df407dfe 8070 TYPE_LENGTH (value_type (arg1))) == 0;
4c4b4cd2
PH
8071 }
8072 return value_equal (arg1, arg2);
8073}
8074
52ce6436
PH
8075/* Total number of component associations in the aggregate starting at
8076 index PC in EXP. Assumes that index PC is the start of an
8077 OP_AGGREGATE. */
8078
8079static int
8080num_component_specs (struct expression *exp, int pc)
8081{
8082 int n, m, i;
8083 m = exp->elts[pc + 1].longconst;
8084 pc += 3;
8085 n = 0;
8086 for (i = 0; i < m; i += 1)
8087 {
8088 switch (exp->elts[pc].opcode)
8089 {
8090 default:
8091 n += 1;
8092 break;
8093 case OP_CHOICES:
8094 n += exp->elts[pc + 1].longconst;
8095 break;
8096 }
8097 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
8098 }
8099 return n;
8100}
8101
8102/* Assign the result of evaluating EXP starting at *POS to the INDEXth
8103 component of LHS (a simple array or a record), updating *POS past
8104 the expression, assuming that LHS is contained in CONTAINER. Does
8105 not modify the inferior's memory, nor does it modify LHS (unless
8106 LHS == CONTAINER). */
8107
8108static void
8109assign_component (struct value *container, struct value *lhs, LONGEST index,
8110 struct expression *exp, int *pos)
8111{
8112 struct value *mark = value_mark ();
8113 struct value *elt;
8114 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
8115 {
8116 struct value *index_val = value_from_longest (builtin_type_int, index);
8117 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
8118 }
8119 else
8120 {
8121 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
8122 elt = ada_to_fixed_value (unwrap_value (elt));
8123 }
8124
8125 if (exp->elts[*pos].opcode == OP_AGGREGATE)
8126 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
8127 else
8128 value_assign_to_component (container, elt,
8129 ada_evaluate_subexp (NULL, exp, pos,
8130 EVAL_NORMAL));
8131
8132 value_free_to_mark (mark);
8133}
8134
8135/* Assuming that LHS represents an lvalue having a record or array
8136 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
8137 of that aggregate's value to LHS, advancing *POS past the
8138 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
8139 lvalue containing LHS (possibly LHS itself). Does not modify
8140 the inferior's memory, nor does it modify the contents of
8141 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
8142
8143static struct value *
8144assign_aggregate (struct value *container,
8145 struct value *lhs, struct expression *exp,
8146 int *pos, enum noside noside)
8147{
8148 struct type *lhs_type;
8149 int n = exp->elts[*pos+1].longconst;
8150 LONGEST low_index, high_index;
8151 int num_specs;
8152 LONGEST *indices;
8153 int max_indices, num_indices;
8154 int is_array_aggregate;
8155 int i;
8156 struct value *mark = value_mark ();
8157
8158 *pos += 3;
8159 if (noside != EVAL_NORMAL)
8160 {
8161 int i;
8162 for (i = 0; i < n; i += 1)
8163 ada_evaluate_subexp (NULL, exp, pos, noside);
8164 return container;
8165 }
8166
8167 container = ada_coerce_ref (container);
8168 if (ada_is_direct_array_type (value_type (container)))
8169 container = ada_coerce_to_simple_array (container);
8170 lhs = ada_coerce_ref (lhs);
8171 if (!deprecated_value_modifiable (lhs))
8172 error (_("Left operand of assignment is not a modifiable lvalue."));
8173
8174 lhs_type = value_type (lhs);
8175 if (ada_is_direct_array_type (lhs_type))
8176 {
8177 lhs = ada_coerce_to_simple_array (lhs);
8178 lhs_type = value_type (lhs);
8179 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
8180 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
8181 is_array_aggregate = 1;
8182 }
8183 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
8184 {
8185 low_index = 0;
8186 high_index = num_visible_fields (lhs_type) - 1;
8187 is_array_aggregate = 0;
8188 }
8189 else
8190 error (_("Left-hand side must be array or record."));
8191
8192 num_specs = num_component_specs (exp, *pos - 3);
8193 max_indices = 4 * num_specs + 4;
8194 indices = alloca (max_indices * sizeof (indices[0]));
8195 indices[0] = indices[1] = low_index - 1;
8196 indices[2] = indices[3] = high_index + 1;
8197 num_indices = 4;
8198
8199 for (i = 0; i < n; i += 1)
8200 {
8201 switch (exp->elts[*pos].opcode)
8202 {
8203 case OP_CHOICES:
8204 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
8205 &num_indices, max_indices,
8206 low_index, high_index);
8207 break;
8208 case OP_POSITIONAL:
8209 aggregate_assign_positional (container, lhs, exp, pos, indices,
8210 &num_indices, max_indices,
8211 low_index, high_index);
8212 break;
8213 case OP_OTHERS:
8214 if (i != n-1)
8215 error (_("Misplaced 'others' clause"));
8216 aggregate_assign_others (container, lhs, exp, pos, indices,
8217 num_indices, low_index, high_index);
8218 break;
8219 default:
8220 error (_("Internal error: bad aggregate clause"));
8221 }
8222 }
8223
8224 return container;
8225}
8226
8227/* Assign into the component of LHS indexed by the OP_POSITIONAL
8228 construct at *POS, updating *POS past the construct, given that
8229 the positions are relative to lower bound LOW, where HIGH is the
8230 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
8231 updating *NUM_INDICES as needed. CONTAINER is as for
8232 assign_aggregate. */
8233static void
8234aggregate_assign_positional (struct value *container,
8235 struct value *lhs, struct expression *exp,
8236 int *pos, LONGEST *indices, int *num_indices,
8237 int max_indices, LONGEST low, LONGEST high)
8238{
8239 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
8240
8241 if (ind - 1 == high)
e1d5a0d2 8242 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
8243 if (ind <= high)
8244 {
8245 add_component_interval (ind, ind, indices, num_indices, max_indices);
8246 *pos += 3;
8247 assign_component (container, lhs, ind, exp, pos);
8248 }
8249 else
8250 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8251}
8252
8253/* Assign into the components of LHS indexed by the OP_CHOICES
8254 construct at *POS, updating *POS past the construct, given that
8255 the allowable indices are LOW..HIGH. Record the indices assigned
8256 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
8257 needed. CONTAINER is as for assign_aggregate. */
8258static void
8259aggregate_assign_from_choices (struct value *container,
8260 struct value *lhs, struct expression *exp,
8261 int *pos, LONGEST *indices, int *num_indices,
8262 int max_indices, LONGEST low, LONGEST high)
8263{
8264 int j;
8265 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
8266 int choice_pos, expr_pc;
8267 int is_array = ada_is_direct_array_type (value_type (lhs));
8268
8269 choice_pos = *pos += 3;
8270
8271 for (j = 0; j < n_choices; j += 1)
8272 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8273 expr_pc = *pos;
8274 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8275
8276 for (j = 0; j < n_choices; j += 1)
8277 {
8278 LONGEST lower, upper;
8279 enum exp_opcode op = exp->elts[choice_pos].opcode;
8280 if (op == OP_DISCRETE_RANGE)
8281 {
8282 choice_pos += 1;
8283 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8284 EVAL_NORMAL));
8285 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8286 EVAL_NORMAL));
8287 }
8288 else if (is_array)
8289 {
8290 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
8291 EVAL_NORMAL));
8292 upper = lower;
8293 }
8294 else
8295 {
8296 int ind;
8297 char *name;
8298 switch (op)
8299 {
8300 case OP_NAME:
8301 name = &exp->elts[choice_pos + 2].string;
8302 break;
8303 case OP_VAR_VALUE:
8304 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
8305 break;
8306 default:
8307 error (_("Invalid record component association."));
8308 }
8309 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
8310 ind = 0;
8311 if (! find_struct_field (name, value_type (lhs), 0,
8312 NULL, NULL, NULL, NULL, &ind))
8313 error (_("Unknown component name: %s."), name);
8314 lower = upper = ind;
8315 }
8316
8317 if (lower <= upper && (lower < low || upper > high))
8318 error (_("Index in component association out of bounds."));
8319
8320 add_component_interval (lower, upper, indices, num_indices,
8321 max_indices);
8322 while (lower <= upper)
8323 {
8324 int pos1;
8325 pos1 = expr_pc;
8326 assign_component (container, lhs, lower, exp, &pos1);
8327 lower += 1;
8328 }
8329 }
8330}
8331
8332/* Assign the value of the expression in the OP_OTHERS construct in
8333 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8334 have not been previously assigned. The index intervals already assigned
8335 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
8336 OP_OTHERS clause. CONTAINER is as for assign_aggregate*/
8337static void
8338aggregate_assign_others (struct value *container,
8339 struct value *lhs, struct expression *exp,
8340 int *pos, LONGEST *indices, int num_indices,
8341 LONGEST low, LONGEST high)
8342{
8343 int i;
8344 int expr_pc = *pos+1;
8345
8346 for (i = 0; i < num_indices - 2; i += 2)
8347 {
8348 LONGEST ind;
8349 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
8350 {
8351 int pos;
8352 pos = expr_pc;
8353 assign_component (container, lhs, ind, exp, &pos);
8354 }
8355 }
8356 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8357}
8358
8359/* Add the interval [LOW .. HIGH] to the sorted set of intervals
8360 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8361 modifying *SIZE as needed. It is an error if *SIZE exceeds
8362 MAX_SIZE. The resulting intervals do not overlap. */
8363static void
8364add_component_interval (LONGEST low, LONGEST high,
8365 LONGEST* indices, int *size, int max_size)
8366{
8367 int i, j;
8368 for (i = 0; i < *size; i += 2) {
8369 if (high >= indices[i] && low <= indices[i + 1])
8370 {
8371 int kh;
8372 for (kh = i + 2; kh < *size; kh += 2)
8373 if (high < indices[kh])
8374 break;
8375 if (low < indices[i])
8376 indices[i] = low;
8377 indices[i + 1] = indices[kh - 1];
8378 if (high > indices[i + 1])
8379 indices[i + 1] = high;
8380 memcpy (indices + i + 2, indices + kh, *size - kh);
8381 *size -= kh - i - 2;
8382 return;
8383 }
8384 else if (high < indices[i])
8385 break;
8386 }
8387
8388 if (*size == max_size)
8389 error (_("Internal error: miscounted aggregate components."));
8390 *size += 2;
8391 for (j = *size-1; j >= i+2; j -= 1)
8392 indices[j] = indices[j - 2];
8393 indices[i] = low;
8394 indices[i + 1] = high;
8395}
8396
6e48bd2c
JB
8397/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8398 is different. */
8399
8400static struct value *
8401ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
8402{
8403 if (type == ada_check_typedef (value_type (arg2)))
8404 return arg2;
8405
8406 if (ada_is_fixed_point_type (type))
8407 return (cast_to_fixed (type, arg2));
8408
8409 if (ada_is_fixed_point_type (value_type (arg2)))
8410 return value_cast (type, cast_from_fixed_to_double (arg2));
8411
8412 return value_cast (type, arg2);
8413}
8414
52ce6436 8415static struct value *
ebf56fd3 8416ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 8417 int *pos, enum noside noside)
14f9c5c9
AS
8418{
8419 enum exp_opcode op;
14f9c5c9
AS
8420 int tem, tem2, tem3;
8421 int pc;
8422 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
8423 struct type *type;
52ce6436 8424 int nargs, oplen;
d2e4a39e 8425 struct value **argvec;
14f9c5c9 8426
d2e4a39e
AS
8427 pc = *pos;
8428 *pos += 1;
14f9c5c9
AS
8429 op = exp->elts[pc].opcode;
8430
d2e4a39e 8431 switch (op)
14f9c5c9
AS
8432 {
8433 default:
8434 *pos -= 1;
6e48bd2c
JB
8435 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
8436 arg1 = unwrap_value (arg1);
8437
8438 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
8439 then we need to perform the conversion manually, because
8440 evaluate_subexp_standard doesn't do it. This conversion is
8441 necessary in Ada because the different kinds of float/fixed
8442 types in Ada have different representations.
8443
8444 Similarly, we need to perform the conversion from OP_LONG
8445 ourselves. */
8446 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
8447 arg1 = ada_value_cast (expect_type, arg1, noside);
8448
8449 return arg1;
4c4b4cd2
PH
8450
8451 case OP_STRING:
8452 {
76a01679
JB
8453 struct value *result;
8454 *pos -= 1;
8455 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
8456 /* The result type will have code OP_STRING, bashed there from
8457 OP_ARRAY. Bash it back. */
df407dfe
AC
8458 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
8459 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 8460 return result;
4c4b4cd2 8461 }
14f9c5c9
AS
8462
8463 case UNOP_CAST:
8464 (*pos) += 2;
8465 type = exp->elts[pc + 1].type;
8466 arg1 = evaluate_subexp (type, exp, pos, noside);
8467 if (noside == EVAL_SKIP)
4c4b4cd2 8468 goto nosideret;
6e48bd2c 8469 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
8470 return arg1;
8471
4c4b4cd2
PH
8472 case UNOP_QUAL:
8473 (*pos) += 2;
8474 type = exp->elts[pc + 1].type;
8475 return ada_evaluate_subexp (type, exp, pos, noside);
8476
14f9c5c9
AS
8477 case BINOP_ASSIGN:
8478 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
8479 if (exp->elts[*pos].opcode == OP_AGGREGATE)
8480 {
8481 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
8482 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
8483 return arg1;
8484 return ada_value_assign (arg1, arg1);
8485 }
003f3813
JB
8486 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
8487 except if the lhs of our assignment is a convenience variable.
8488 In the case of assigning to a convenience variable, the lhs
8489 should be exactly the result of the evaluation of the rhs. */
8490 type = value_type (arg1);
8491 if (VALUE_LVAL (arg1) == lval_internalvar)
8492 type = NULL;
8493 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 8494 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 8495 return arg1;
df407dfe
AC
8496 if (ada_is_fixed_point_type (value_type (arg1)))
8497 arg2 = cast_to_fixed (value_type (arg1), arg2);
8498 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 8499 error
323e0a4a 8500 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 8501 else
df407dfe 8502 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 8503 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
8504
8505 case BINOP_ADD:
8506 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8507 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8508 if (noside == EVAL_SKIP)
4c4b4cd2 8509 goto nosideret;
df407dfe
AC
8510 if ((ada_is_fixed_point_type (value_type (arg1))
8511 || ada_is_fixed_point_type (value_type (arg2)))
8512 && value_type (arg1) != value_type (arg2))
323e0a4a 8513 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
8514 /* Do the addition, and cast the result to the type of the first
8515 argument. We cannot cast the result to a reference type, so if
8516 ARG1 is a reference type, find its underlying type. */
8517 type = value_type (arg1);
8518 while (TYPE_CODE (type) == TYPE_CODE_REF)
8519 type = TYPE_TARGET_TYPE (type);
8520 return value_cast (type, value_add (arg1, arg2));
14f9c5c9
AS
8521
8522 case BINOP_SUB:
8523 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8524 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8525 if (noside == EVAL_SKIP)
4c4b4cd2 8526 goto nosideret;
df407dfe
AC
8527 if ((ada_is_fixed_point_type (value_type (arg1))
8528 || ada_is_fixed_point_type (value_type (arg2)))
8529 && value_type (arg1) != value_type (arg2))
323e0a4a 8530 error (_("Operands of fixed-point subtraction must have the same type"));
b7789565
JB
8531 /* Do the substraction, and cast the result to the type of the first
8532 argument. We cannot cast the result to a reference type, so if
8533 ARG1 is a reference type, find its underlying type. */
8534 type = value_type (arg1);
8535 while (TYPE_CODE (type) == TYPE_CODE_REF)
8536 type = TYPE_TARGET_TYPE (type);
8537 return value_cast (type, value_sub (arg1, arg2));
14f9c5c9
AS
8538
8539 case BINOP_MUL:
8540 case BINOP_DIV:
8541 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8542 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8543 if (noside == EVAL_SKIP)
4c4b4cd2
PH
8544 goto nosideret;
8545 else if (noside == EVAL_AVOID_SIDE_EFFECTS
76a01679 8546 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
df407dfe 8547 return value_zero (value_type (arg1), not_lval);
14f9c5c9 8548 else
4c4b4cd2 8549 {
df407dfe 8550 if (ada_is_fixed_point_type (value_type (arg1)))
4c4b4cd2 8551 arg1 = cast_from_fixed_to_double (arg1);
df407dfe 8552 if (ada_is_fixed_point_type (value_type (arg2)))
4c4b4cd2
PH
8553 arg2 = cast_from_fixed_to_double (arg2);
8554 return ada_value_binop (arg1, arg2, op);
8555 }
8556
8557 case BINOP_REM:
8558 case BINOP_MOD:
8559 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8560 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8561 if (noside == EVAL_SKIP)
76a01679 8562 goto nosideret;
4c4b4cd2 8563 else if (noside == EVAL_AVOID_SIDE_EFFECTS
76a01679 8564 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
df407dfe 8565 return value_zero (value_type (arg1), not_lval);
14f9c5c9 8566 else
76a01679 8567 return ada_value_binop (arg1, arg2, op);
14f9c5c9 8568
4c4b4cd2
PH
8569 case BINOP_EQUAL:
8570 case BINOP_NOTEQUAL:
14f9c5c9 8571 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 8572 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 8573 if (noside == EVAL_SKIP)
76a01679 8574 goto nosideret;
4c4b4cd2 8575 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 8576 tem = 0;
4c4b4cd2 8577 else
76a01679 8578 tem = ada_value_equal (arg1, arg2);
4c4b4cd2 8579 if (op == BINOP_NOTEQUAL)
76a01679 8580 tem = !tem;
4c4b4cd2
PH
8581 return value_from_longest (LA_BOOL_TYPE, (LONGEST) tem);
8582
8583 case UNOP_NEG:
8584 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8585 if (noside == EVAL_SKIP)
8586 goto nosideret;
df407dfe
AC
8587 else if (ada_is_fixed_point_type (value_type (arg1)))
8588 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 8589 else
4c4b4cd2
PH
8590 return value_neg (arg1);
8591
2330c6c6
JB
8592 case BINOP_LOGICAL_AND:
8593 case BINOP_LOGICAL_OR:
8594 case UNOP_LOGICAL_NOT:
000d5124
JB
8595 {
8596 struct value *val;
8597
8598 *pos -= 1;
8599 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
8600 return value_cast (LA_BOOL_TYPE, val);
8601 }
2330c6c6
JB
8602
8603 case BINOP_BITWISE_AND:
8604 case BINOP_BITWISE_IOR:
8605 case BINOP_BITWISE_XOR:
000d5124
JB
8606 {
8607 struct value *val;
8608
8609 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
8610 *pos = pc;
8611 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
8612
8613 return value_cast (value_type (arg1), val);
8614 }
2330c6c6 8615
14f9c5c9
AS
8616 case OP_VAR_VALUE:
8617 *pos -= 1;
6799def4
JB
8618
8619 /* Tagged types are a little special in the fact that the real type
8620 is dynamic and can only be determined by inspecting the object
8621 value. So even if we're support to do an EVAL_AVOID_SIDE_EFFECTS
8622 evaluation, we force an EVAL_NORMAL evaluation for tagged types. */
8623 if (noside == EVAL_AVOID_SIDE_EFFECTS
8624 && ada_is_tagged_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol), 1))
8625 noside = EVAL_NORMAL;
8626
14f9c5c9 8627 if (noside == EVAL_SKIP)
4c4b4cd2
PH
8628 {
8629 *pos += 4;
8630 goto nosideret;
8631 }
8632 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
8633 /* Only encountered when an unresolved symbol occurs in a
8634 context other than a function call, in which case, it is
52ce6436 8635 invalid. */
323e0a4a 8636 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 8637 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
14f9c5c9 8638 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
8639 {
8640 *pos += 4;
8641 return value_zero
8642 (to_static_fixed_type
8643 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
8644 not_lval);
8645 }
d2e4a39e 8646 else
4c4b4cd2
PH
8647 {
8648 arg1 =
8649 unwrap_value (evaluate_subexp_standard
8650 (expect_type, exp, pos, noside));
8651 return ada_to_fixed_value (arg1);
8652 }
8653
8654 case OP_FUNCALL:
8655 (*pos) += 2;
8656
8657 /* Allocate arg vector, including space for the function to be
8658 called in argvec[0] and a terminating NULL. */
8659 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8660 argvec =
8661 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
8662
8663 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 8664 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 8665 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
8666 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
8667 else
8668 {
8669 for (tem = 0; tem <= nargs; tem += 1)
8670 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8671 argvec[tem] = 0;
8672
8673 if (noside == EVAL_SKIP)
8674 goto nosideret;
8675 }
8676
df407dfe 8677 if (ada_is_packed_array_type (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 8678 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
df407dfe
AC
8679 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
8680 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
76a01679 8681 && VALUE_LVAL (argvec[0]) == lval_memory))
4c4b4cd2
PH
8682 argvec[0] = value_addr (argvec[0]);
8683
df407dfe 8684 type = ada_check_typedef (value_type (argvec[0]));
4c4b4cd2
PH
8685 if (TYPE_CODE (type) == TYPE_CODE_PTR)
8686 {
61ee279c 8687 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
8688 {
8689 case TYPE_CODE_FUNC:
61ee279c 8690 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
8691 break;
8692 case TYPE_CODE_ARRAY:
8693 break;
8694 case TYPE_CODE_STRUCT:
8695 if (noside != EVAL_AVOID_SIDE_EFFECTS)
8696 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 8697 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
8698 break;
8699 default:
323e0a4a 8700 error (_("cannot subscript or call something of type `%s'"),
df407dfe 8701 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
8702 break;
8703 }
8704 }
8705
8706 switch (TYPE_CODE (type))
8707 {
8708 case TYPE_CODE_FUNC:
8709 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8710 return allocate_value (TYPE_TARGET_TYPE (type));
8711 return call_function_by_hand (argvec[0], nargs, argvec + 1);
8712 case TYPE_CODE_STRUCT:
8713 {
8714 int arity;
8715
4c4b4cd2
PH
8716 arity = ada_array_arity (type);
8717 type = ada_array_element_type (type, nargs);
8718 if (type == NULL)
323e0a4a 8719 error (_("cannot subscript or call a record"));
4c4b4cd2 8720 if (arity != nargs)
323e0a4a 8721 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 8722 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 8723 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
8724 return
8725 unwrap_value (ada_value_subscript
8726 (argvec[0], nargs, argvec + 1));
8727 }
8728 case TYPE_CODE_ARRAY:
8729 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8730 {
8731 type = ada_array_element_type (type, nargs);
8732 if (type == NULL)
323e0a4a 8733 error (_("element type of array unknown"));
4c4b4cd2 8734 else
0a07e705 8735 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
8736 }
8737 return
8738 unwrap_value (ada_value_subscript
8739 (ada_coerce_to_simple_array (argvec[0]),
8740 nargs, argvec + 1));
8741 case TYPE_CODE_PTR: /* Pointer to array */
8742 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
8743 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8744 {
8745 type = ada_array_element_type (type, nargs);
8746 if (type == NULL)
323e0a4a 8747 error (_("element type of array unknown"));
4c4b4cd2 8748 else
0a07e705 8749 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
8750 }
8751 return
8752 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
8753 nargs, argvec + 1));
8754
8755 default:
e1d5a0d2
PH
8756 error (_("Attempt to index or call something other than an "
8757 "array or function"));
4c4b4cd2
PH
8758 }
8759
8760 case TERNOP_SLICE:
8761 {
8762 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8763 struct value *low_bound_val =
8764 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
8765 struct value *high_bound_val =
8766 evaluate_subexp (NULL_TYPE, exp, pos, noside);
8767 LONGEST low_bound;
8768 LONGEST high_bound;
994b9211
AC
8769 low_bound_val = coerce_ref (low_bound_val);
8770 high_bound_val = coerce_ref (high_bound_val);
714e53ab
PH
8771 low_bound = pos_atr (low_bound_val);
8772 high_bound = pos_atr (high_bound_val);
963a6417 8773
4c4b4cd2
PH
8774 if (noside == EVAL_SKIP)
8775 goto nosideret;
8776
4c4b4cd2
PH
8777 /* If this is a reference to an aligner type, then remove all
8778 the aligners. */
df407dfe
AC
8779 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8780 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
8781 TYPE_TARGET_TYPE (value_type (array)) =
8782 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 8783
df407dfe 8784 if (ada_is_packed_array_type (value_type (array)))
323e0a4a 8785 error (_("cannot slice a packed array"));
4c4b4cd2
PH
8786
8787 /* If this is a reference to an array or an array lvalue,
8788 convert to a pointer. */
df407dfe
AC
8789 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8790 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
8791 && VALUE_LVAL (array) == lval_memory))
8792 array = value_addr (array);
8793
1265e4aa 8794 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 8795 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 8796 (value_type (array))))
0b5d8877 8797 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
8798
8799 array = ada_coerce_to_simple_array_ptr (array);
8800
714e53ab
PH
8801 /* If we have more than one level of pointer indirection,
8802 dereference the value until we get only one level. */
df407dfe
AC
8803 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
8804 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
8805 == TYPE_CODE_PTR))
8806 array = value_ind (array);
8807
8808 /* Make sure we really do have an array type before going further,
8809 to avoid a SEGV when trying to get the index type or the target
8810 type later down the road if the debug info generated by
8811 the compiler is incorrect or incomplete. */
df407dfe 8812 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 8813 error (_("cannot take slice of non-array"));
714e53ab 8814
df407dfe 8815 if (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR)
4c4b4cd2 8816 {
0b5d8877 8817 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 8818 return empty_array (TYPE_TARGET_TYPE (value_type (array)),
4c4b4cd2
PH
8819 low_bound);
8820 else
8821 {
8822 struct type *arr_type0 =
df407dfe 8823 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array)),
4c4b4cd2 8824 NULL, 1);
0b5d8877 8825 return ada_value_slice_ptr (array, arr_type0,
529cad9c
PH
8826 longest_to_int (low_bound),
8827 longest_to_int (high_bound));
4c4b4cd2
PH
8828 }
8829 }
8830 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8831 return array;
8832 else if (high_bound < low_bound)
df407dfe 8833 return empty_array (value_type (array), low_bound);
4c4b4cd2 8834 else
529cad9c
PH
8835 return ada_value_slice (array, longest_to_int (low_bound),
8836 longest_to_int (high_bound));
4c4b4cd2 8837 }
14f9c5c9 8838
4c4b4cd2
PH
8839 case UNOP_IN_RANGE:
8840 (*pos) += 2;
8841 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8842 type = exp->elts[pc + 1].type;
14f9c5c9 8843
14f9c5c9 8844 if (noside == EVAL_SKIP)
4c4b4cd2 8845 goto nosideret;
14f9c5c9 8846
4c4b4cd2
PH
8847 switch (TYPE_CODE (type))
8848 {
8849 default:
e1d5a0d2
PH
8850 lim_warning (_("Membership test incompletely implemented; "
8851 "always returns true"));
4c4b4cd2
PH
8852 return value_from_longest (builtin_type_int, (LONGEST) 1);
8853
8854 case TYPE_CODE_RANGE:
76a01679 8855 arg2 = value_from_longest (builtin_type_int, TYPE_LOW_BOUND (type));
4c4b4cd2
PH
8856 arg3 = value_from_longest (builtin_type_int,
8857 TYPE_HIGH_BOUND (type));
8858 return
8859 value_from_longest (builtin_type_int,
8860 (value_less (arg1, arg3)
8861 || value_equal (arg1, arg3))
8862 && (value_less (arg2, arg1)
8863 || value_equal (arg2, arg1)));
8864 }
8865
8866 case BINOP_IN_BOUNDS:
14f9c5c9 8867 (*pos) += 2;
4c4b4cd2
PH
8868 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8869 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 8870
4c4b4cd2
PH
8871 if (noside == EVAL_SKIP)
8872 goto nosideret;
14f9c5c9 8873
4c4b4cd2
PH
8874 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8875 return value_zero (builtin_type_int, not_lval);
14f9c5c9 8876
4c4b4cd2 8877 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 8878
df407dfe 8879 if (tem < 1 || tem > ada_array_arity (value_type (arg2)))
323e0a4a 8880 error (_("invalid dimension number to 'range"));
14f9c5c9 8881
4c4b4cd2
PH
8882 arg3 = ada_array_bound (arg2, tem, 1);
8883 arg2 = ada_array_bound (arg2, tem, 0);
d2e4a39e 8884
4c4b4cd2
PH
8885 return
8886 value_from_longest (builtin_type_int,
8887 (value_less (arg1, arg3)
8888 || value_equal (arg1, arg3))
8889 && (value_less (arg2, arg1)
8890 || value_equal (arg2, arg1)));
8891
8892 case TERNOP_IN_RANGE:
8893 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8894 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8895 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8896
8897 if (noside == EVAL_SKIP)
8898 goto nosideret;
8899
8900 return
8901 value_from_longest (builtin_type_int,
8902 (value_less (arg1, arg3)
8903 || value_equal (arg1, arg3))
8904 && (value_less (arg2, arg1)
8905 || value_equal (arg2, arg1)));
8906
8907 case OP_ATR_FIRST:
8908 case OP_ATR_LAST:
8909 case OP_ATR_LENGTH:
8910 {
76a01679
JB
8911 struct type *type_arg;
8912 if (exp->elts[*pos].opcode == OP_TYPE)
8913 {
8914 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
8915 arg1 = NULL;
8916 type_arg = exp->elts[pc + 2].type;
8917 }
8918 else
8919 {
8920 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8921 type_arg = NULL;
8922 }
8923
8924 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 8925 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
8926 tem = longest_to_int (exp->elts[*pos + 2].longconst);
8927 *pos += 4;
8928
8929 if (noside == EVAL_SKIP)
8930 goto nosideret;
8931
8932 if (type_arg == NULL)
8933 {
8934 arg1 = ada_coerce_ref (arg1);
8935
df407dfe 8936 if (ada_is_packed_array_type (value_type (arg1)))
76a01679
JB
8937 arg1 = ada_coerce_to_simple_array (arg1);
8938
df407dfe 8939 if (tem < 1 || tem > ada_array_arity (value_type (arg1)))
323e0a4a 8940 error (_("invalid dimension number to '%s"),
76a01679
JB
8941 ada_attribute_name (op));
8942
8943 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8944 {
df407dfe 8945 type = ada_index_type (value_type (arg1), tem);
76a01679
JB
8946 if (type == NULL)
8947 error
323e0a4a 8948 (_("attempt to take bound of something that is not an array"));
76a01679
JB
8949 return allocate_value (type);
8950 }
8951
8952 switch (op)
8953 {
8954 default: /* Should never happen. */
323e0a4a 8955 error (_("unexpected attribute encountered"));
76a01679
JB
8956 case OP_ATR_FIRST:
8957 return ada_array_bound (arg1, tem, 0);
8958 case OP_ATR_LAST:
8959 return ada_array_bound (arg1, tem, 1);
8960 case OP_ATR_LENGTH:
8961 return ada_array_length (arg1, tem);
8962 }
8963 }
8964 else if (discrete_type_p (type_arg))
8965 {
8966 struct type *range_type;
8967 char *name = ada_type_name (type_arg);
8968 range_type = NULL;
8969 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
8970 range_type =
8971 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
8972 if (range_type == NULL)
8973 range_type = type_arg;
8974 switch (op)
8975 {
8976 default:
323e0a4a 8977 error (_("unexpected attribute encountered"));
76a01679
JB
8978 case OP_ATR_FIRST:
8979 return discrete_type_low_bound (range_type);
8980 case OP_ATR_LAST:
8981 return discrete_type_high_bound (range_type);
8982 case OP_ATR_LENGTH:
323e0a4a 8983 error (_("the 'length attribute applies only to array types"));
76a01679
JB
8984 }
8985 }
8986 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 8987 error (_("unimplemented type attribute"));
76a01679
JB
8988 else
8989 {
8990 LONGEST low, high;
8991
8992 if (ada_is_packed_array_type (type_arg))
8993 type_arg = decode_packed_array_type (type_arg);
8994
8995 if (tem < 1 || tem > ada_array_arity (type_arg))
323e0a4a 8996 error (_("invalid dimension number to '%s"),
76a01679
JB
8997 ada_attribute_name (op));
8998
8999 type = ada_index_type (type_arg, tem);
9000 if (type == NULL)
9001 error
323e0a4a 9002 (_("attempt to take bound of something that is not an array"));
76a01679
JB
9003 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9004 return allocate_value (type);
9005
9006 switch (op)
9007 {
9008 default:
323e0a4a 9009 error (_("unexpected attribute encountered"));
76a01679
JB
9010 case OP_ATR_FIRST:
9011 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
9012 return value_from_longest (type, low);
9013 case OP_ATR_LAST:
9014 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
9015 return value_from_longest (type, high);
9016 case OP_ATR_LENGTH:
9017 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
9018 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
9019 return value_from_longest (type, high - low + 1);
9020 }
9021 }
14f9c5c9
AS
9022 }
9023
4c4b4cd2
PH
9024 case OP_ATR_TAG:
9025 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9026 if (noside == EVAL_SKIP)
76a01679 9027 goto nosideret;
4c4b4cd2
PH
9028
9029 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9030 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
9031
9032 return ada_value_tag (arg1);
9033
9034 case OP_ATR_MIN:
9035 case OP_ATR_MAX:
9036 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
9037 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9038 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9039 if (noside == EVAL_SKIP)
76a01679 9040 goto nosideret;
d2e4a39e 9041 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 9042 return value_zero (value_type (arg1), not_lval);
14f9c5c9 9043 else
76a01679
JB
9044 return value_binop (arg1, arg2,
9045 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
14f9c5c9 9046
4c4b4cd2
PH
9047 case OP_ATR_MODULUS:
9048 {
76a01679
JB
9049 struct type *type_arg = exp->elts[pc + 2].type;
9050 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
4c4b4cd2 9051
76a01679
JB
9052 if (noside == EVAL_SKIP)
9053 goto nosideret;
4c4b4cd2 9054
76a01679 9055 if (!ada_is_modular_type (type_arg))
323e0a4a 9056 error (_("'modulus must be applied to modular type"));
4c4b4cd2 9057
76a01679
JB
9058 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
9059 ada_modulus (type_arg));
4c4b4cd2
PH
9060 }
9061
9062
9063 case OP_ATR_POS:
9064 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
9065 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9066 if (noside == EVAL_SKIP)
76a01679 9067 goto nosideret;
4c4b4cd2 9068 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
72d5681a 9069 return value_zero (builtin_type_int, not_lval);
14f9c5c9 9070 else
76a01679 9071 return value_pos_atr (arg1);
14f9c5c9 9072
4c4b4cd2
PH
9073 case OP_ATR_SIZE:
9074 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9075 if (noside == EVAL_SKIP)
76a01679 9076 goto nosideret;
4c4b4cd2 9077 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
72d5681a 9078 return value_zero (builtin_type_int, not_lval);
4c4b4cd2 9079 else
72d5681a 9080 return value_from_longest (builtin_type_int,
76a01679 9081 TARGET_CHAR_BIT
df407dfe 9082 * TYPE_LENGTH (value_type (arg1)));
4c4b4cd2
PH
9083
9084 case OP_ATR_VAL:
9085 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 9086 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 9087 type = exp->elts[pc + 2].type;
14f9c5c9 9088 if (noside == EVAL_SKIP)
76a01679 9089 goto nosideret;
4c4b4cd2 9090 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9091 return value_zero (type, not_lval);
4c4b4cd2 9092 else
76a01679 9093 return value_val_atr (type, arg1);
4c4b4cd2
PH
9094
9095 case BINOP_EXP:
9096 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9097 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9098 if (noside == EVAL_SKIP)
9099 goto nosideret;
9100 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 9101 return value_zero (value_type (arg1), not_lval);
4c4b4cd2
PH
9102 else
9103 return value_binop (arg1, arg2, op);
9104
9105 case UNOP_PLUS:
9106 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9107 if (noside == EVAL_SKIP)
9108 goto nosideret;
9109 else
9110 return arg1;
9111
9112 case UNOP_ABS:
9113 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9114 if (noside == EVAL_SKIP)
9115 goto nosideret;
df407dfe 9116 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 9117 return value_neg (arg1);
14f9c5c9 9118 else
4c4b4cd2 9119 return arg1;
14f9c5c9
AS
9120
9121 case UNOP_IND:
9122 if (expect_type && TYPE_CODE (expect_type) == TYPE_CODE_PTR)
61ee279c 9123 expect_type = TYPE_TARGET_TYPE (ada_check_typedef (expect_type));
14f9c5c9
AS
9124 arg1 = evaluate_subexp (expect_type, exp, pos, noside);
9125 if (noside == EVAL_SKIP)
4c4b4cd2 9126 goto nosideret;
df407dfe 9127 type = ada_check_typedef (value_type (arg1));
14f9c5c9 9128 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
9129 {
9130 if (ada_is_array_descriptor_type (type))
9131 /* GDB allows dereferencing GNAT array descriptors. */
9132 {
9133 struct type *arrType = ada_type_of_array (arg1, 0);
9134 if (arrType == NULL)
323e0a4a 9135 error (_("Attempt to dereference null array pointer."));
00a4c844 9136 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
9137 }
9138 else if (TYPE_CODE (type) == TYPE_CODE_PTR
9139 || TYPE_CODE (type) == TYPE_CODE_REF
9140 /* In C you can dereference an array to get the 1st elt. */
9141 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab
PH
9142 {
9143 type = to_static_fixed_type
9144 (ada_aligned_type
9145 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
9146 check_size (type);
9147 return value_zero (type, lval_memory);
9148 }
4c4b4cd2
PH
9149 else if (TYPE_CODE (type) == TYPE_CODE_INT)
9150 /* GDB allows dereferencing an int. */
9151 return value_zero (builtin_type_int, lval_memory);
9152 else
323e0a4a 9153 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 9154 }
76a01679 9155 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 9156 type = ada_check_typedef (value_type (arg1));
d2e4a39e 9157
4c4b4cd2
PH
9158 if (ada_is_array_descriptor_type (type))
9159 /* GDB allows dereferencing GNAT array descriptors. */
9160 return ada_coerce_to_simple_array (arg1);
14f9c5c9 9161 else
4c4b4cd2 9162 return ada_value_ind (arg1);
14f9c5c9
AS
9163
9164 case STRUCTOP_STRUCT:
9165 tem = longest_to_int (exp->elts[pc + 1].longconst);
9166 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
9167 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9168 if (noside == EVAL_SKIP)
4c4b4cd2 9169 goto nosideret;
14f9c5c9 9170 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9171 {
df407dfe 9172 struct type *type1 = value_type (arg1);
76a01679
JB
9173 if (ada_is_tagged_type (type1, 1))
9174 {
9175 type = ada_lookup_struct_elt_type (type1,
9176 &exp->elts[pc + 2].string,
9177 1, 1, NULL);
9178 if (type == NULL)
9179 /* In this case, we assume that the field COULD exist
9180 in some extension of the type. Return an object of
9181 "type" void, which will match any formal
9182 (see ada_type_match). */
9183 return value_zero (builtin_type_void, lval_memory);
9184 }
9185 else
9186 type =
9187 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
9188 0, NULL);
9189
9190 return value_zero (ada_aligned_type (type), lval_memory);
9191 }
14f9c5c9 9192 else
76a01679
JB
9193 return
9194 ada_to_fixed_value (unwrap_value
9195 (ada_value_struct_elt
03ee6b2e 9196 (arg1, &exp->elts[pc + 2].string, 0)));
14f9c5c9 9197 case OP_TYPE:
4c4b4cd2
PH
9198 /* The value is not supposed to be used. This is here to make it
9199 easier to accommodate expressions that contain types. */
14f9c5c9
AS
9200 (*pos) += 2;
9201 if (noside == EVAL_SKIP)
4c4b4cd2 9202 goto nosideret;
14f9c5c9 9203 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 9204 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 9205 else
323e0a4a 9206 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
9207
9208 case OP_AGGREGATE:
9209 case OP_CHOICES:
9210 case OP_OTHERS:
9211 case OP_DISCRETE_RANGE:
9212 case OP_POSITIONAL:
9213 case OP_NAME:
9214 if (noside == EVAL_NORMAL)
9215 switch (op)
9216 {
9217 case OP_NAME:
9218 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 9219 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
9220 case OP_AGGREGATE:
9221 error (_("Aggregates only allowed on the right of an assignment"));
9222 default:
e1d5a0d2 9223 internal_error (__FILE__, __LINE__, _("aggregate apparently mangled"));
52ce6436
PH
9224 }
9225
9226 ada_forward_operator_length (exp, pc, &oplen, &nargs);
9227 *pos += oplen - 1;
9228 for (tem = 0; tem < nargs; tem += 1)
9229 ada_evaluate_subexp (NULL, exp, pos, noside);
9230 goto nosideret;
14f9c5c9
AS
9231 }
9232
9233nosideret:
9234 return value_from_longest (builtin_type_long, (LONGEST) 1);
9235}
14f9c5c9 9236\f
d2e4a39e 9237
4c4b4cd2 9238 /* Fixed point */
14f9c5c9
AS
9239
9240/* If TYPE encodes an Ada fixed-point type, return the suffix of the
9241 type name that encodes the 'small and 'delta information.
4c4b4cd2 9242 Otherwise, return NULL. */
14f9c5c9 9243
d2e4a39e 9244static const char *
ebf56fd3 9245fixed_type_info (struct type *type)
14f9c5c9 9246{
d2e4a39e 9247 const char *name = ada_type_name (type);
14f9c5c9
AS
9248 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
9249
d2e4a39e
AS
9250 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
9251 {
14f9c5c9
AS
9252 const char *tail = strstr (name, "___XF_");
9253 if (tail == NULL)
4c4b4cd2 9254 return NULL;
d2e4a39e 9255 else
4c4b4cd2 9256 return tail + 5;
14f9c5c9
AS
9257 }
9258 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
9259 return fixed_type_info (TYPE_TARGET_TYPE (type));
9260 else
9261 return NULL;
9262}
9263
4c4b4cd2 9264/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
9265
9266int
ebf56fd3 9267ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
9268{
9269 return fixed_type_info (type) != NULL;
9270}
9271
4c4b4cd2
PH
9272/* Return non-zero iff TYPE represents a System.Address type. */
9273
9274int
9275ada_is_system_address_type (struct type *type)
9276{
9277 return (TYPE_NAME (type)
9278 && strcmp (TYPE_NAME (type), "system__address") == 0);
9279}
9280
14f9c5c9
AS
9281/* Assuming that TYPE is the representation of an Ada fixed-point
9282 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 9283 delta cannot be determined. */
14f9c5c9
AS
9284
9285DOUBLEST
ebf56fd3 9286ada_delta (struct type *type)
14f9c5c9
AS
9287{
9288 const char *encoding = fixed_type_info (type);
9289 long num, den;
9290
9291 if (sscanf (encoding, "_%ld_%ld", &num, &den) < 2)
9292 return -1.0;
d2e4a39e 9293 else
14f9c5c9
AS
9294 return (DOUBLEST) num / (DOUBLEST) den;
9295}
9296
9297/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 9298 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
9299
9300static DOUBLEST
ebf56fd3 9301scaling_factor (struct type *type)
14f9c5c9
AS
9302{
9303 const char *encoding = fixed_type_info (type);
9304 unsigned long num0, den0, num1, den1;
9305 int n;
d2e4a39e 9306
14f9c5c9
AS
9307 n = sscanf (encoding, "_%lu_%lu_%lu_%lu", &num0, &den0, &num1, &den1);
9308
9309 if (n < 2)
9310 return 1.0;
9311 else if (n == 4)
9312 return (DOUBLEST) num1 / (DOUBLEST) den1;
d2e4a39e 9313 else
14f9c5c9
AS
9314 return (DOUBLEST) num0 / (DOUBLEST) den0;
9315}
9316
9317
9318/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 9319 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
9320
9321DOUBLEST
ebf56fd3 9322ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 9323{
d2e4a39e 9324 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
9325}
9326
4c4b4cd2
PH
9327/* The representation of a fixed-point value of type TYPE
9328 corresponding to the value X. */
14f9c5c9
AS
9329
9330LONGEST
ebf56fd3 9331ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
9332{
9333 return (LONGEST) (x / scaling_factor (type) + 0.5);
9334}
9335
9336
4c4b4cd2 9337 /* VAX floating formats */
14f9c5c9
AS
9338
9339/* Non-zero iff TYPE represents one of the special VAX floating-point
4c4b4cd2
PH
9340 types. */
9341
14f9c5c9 9342int
d2e4a39e 9343ada_is_vax_floating_type (struct type *type)
14f9c5c9 9344{
d2e4a39e 9345 int name_len =
14f9c5c9 9346 (ada_type_name (type) == NULL) ? 0 : strlen (ada_type_name (type));
d2e4a39e 9347 return
14f9c5c9 9348 name_len > 6
d2e4a39e 9349 && (TYPE_CODE (type) == TYPE_CODE_INT
4c4b4cd2
PH
9350 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9351 && strncmp (ada_type_name (type) + name_len - 6, "___XF", 5) == 0;
14f9c5c9
AS
9352}
9353
9354/* The type of special VAX floating-point type this is, assuming
4c4b4cd2
PH
9355 ada_is_vax_floating_point. */
9356
14f9c5c9 9357int
d2e4a39e 9358ada_vax_float_type_suffix (struct type *type)
14f9c5c9 9359{
d2e4a39e 9360 return ada_type_name (type)[strlen (ada_type_name (type)) - 1];
14f9c5c9
AS
9361}
9362
4c4b4cd2 9363/* A value representing the special debugging function that outputs
14f9c5c9 9364 VAX floating-point values of the type represented by TYPE. Assumes
4c4b4cd2
PH
9365 ada_is_vax_floating_type (TYPE). */
9366
d2e4a39e
AS
9367struct value *
9368ada_vax_float_print_function (struct type *type)
9369{
9370 switch (ada_vax_float_type_suffix (type))
9371 {
9372 case 'F':
9373 return get_var_value ("DEBUG_STRING_F", 0);
9374 case 'D':
9375 return get_var_value ("DEBUG_STRING_D", 0);
9376 case 'G':
9377 return get_var_value ("DEBUG_STRING_G", 0);
9378 default:
323e0a4a 9379 error (_("invalid VAX floating-point type"));
d2e4a39e 9380 }
14f9c5c9 9381}
14f9c5c9 9382\f
d2e4a39e 9383
4c4b4cd2 9384 /* Range types */
14f9c5c9
AS
9385
9386/* Scan STR beginning at position K for a discriminant name, and
9387 return the value of that discriminant field of DVAL in *PX. If
9388 PNEW_K is not null, put the position of the character beyond the
9389 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 9390 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
9391
9392static int
07d8f827 9393scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
76a01679 9394 int *pnew_k)
14f9c5c9
AS
9395{
9396 static char *bound_buffer = NULL;
9397 static size_t bound_buffer_len = 0;
9398 char *bound;
9399 char *pend;
d2e4a39e 9400 struct value *bound_val;
14f9c5c9
AS
9401
9402 if (dval == NULL || str == NULL || str[k] == '\0')
9403 return 0;
9404
d2e4a39e 9405 pend = strstr (str + k, "__");
14f9c5c9
AS
9406 if (pend == NULL)
9407 {
d2e4a39e 9408 bound = str + k;
14f9c5c9
AS
9409 k += strlen (bound);
9410 }
d2e4a39e 9411 else
14f9c5c9 9412 {
d2e4a39e 9413 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
14f9c5c9 9414 bound = bound_buffer;
d2e4a39e
AS
9415 strncpy (bound_buffer, str + k, pend - (str + k));
9416 bound[pend - (str + k)] = '\0';
9417 k = pend - str;
14f9c5c9 9418 }
d2e4a39e 9419
df407dfe 9420 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
9421 if (bound_val == NULL)
9422 return 0;
9423
9424 *px = value_as_long (bound_val);
9425 if (pnew_k != NULL)
9426 *pnew_k = k;
9427 return 1;
9428}
9429
9430/* Value of variable named NAME in the current environment. If
9431 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
9432 otherwise causes an error with message ERR_MSG. */
9433
d2e4a39e
AS
9434static struct value *
9435get_var_value (char *name, char *err_msg)
14f9c5c9 9436{
4c4b4cd2 9437 struct ada_symbol_info *syms;
14f9c5c9
AS
9438 int nsyms;
9439
4c4b4cd2
PH
9440 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
9441 &syms);
14f9c5c9
AS
9442
9443 if (nsyms != 1)
9444 {
9445 if (err_msg == NULL)
4c4b4cd2 9446 return 0;
14f9c5c9 9447 else
8a3fe4f8 9448 error (("%s"), err_msg);
14f9c5c9
AS
9449 }
9450
4c4b4cd2 9451 return value_of_variable (syms[0].sym, syms[0].block);
14f9c5c9 9452}
d2e4a39e 9453
14f9c5c9 9454/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
9455 no such variable found, returns 0, and sets *FLAG to 0. If
9456 successful, sets *FLAG to 1. */
9457
14f9c5c9 9458LONGEST
4c4b4cd2 9459get_int_var_value (char *name, int *flag)
14f9c5c9 9460{
4c4b4cd2 9461 struct value *var_val = get_var_value (name, 0);
d2e4a39e 9462
14f9c5c9
AS
9463 if (var_val == 0)
9464 {
9465 if (flag != NULL)
4c4b4cd2 9466 *flag = 0;
14f9c5c9
AS
9467 return 0;
9468 }
9469 else
9470 {
9471 if (flag != NULL)
4c4b4cd2 9472 *flag = 1;
14f9c5c9
AS
9473 return value_as_long (var_val);
9474 }
9475}
d2e4a39e 9476
14f9c5c9
AS
9477
9478/* Return a range type whose base type is that of the range type named
9479 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 9480 from NAME according to the GNAT range encoding conventions.
14f9c5c9
AS
9481 Extract discriminant values, if needed, from DVAL. If a new type
9482 must be created, allocate in OBJFILE's space. The bounds
9483 information, in general, is encoded in NAME, the base type given in
4c4b4cd2 9484 the named range type. */
14f9c5c9 9485
d2e4a39e 9486static struct type *
ebf56fd3 9487to_fixed_range_type (char *name, struct value *dval, struct objfile *objfile)
14f9c5c9
AS
9488{
9489 struct type *raw_type = ada_find_any_type (name);
9490 struct type *base_type;
d2e4a39e 9491 char *subtype_info;
14f9c5c9
AS
9492
9493 if (raw_type == NULL)
9494 base_type = builtin_type_int;
9495 else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
9496 base_type = TYPE_TARGET_TYPE (raw_type);
9497 else
9498 base_type = raw_type;
9499
9500 subtype_info = strstr (name, "___XD");
9501 if (subtype_info == NULL)
9502 return raw_type;
9503 else
9504 {
9505 static char *name_buf = NULL;
9506 static size_t name_len = 0;
9507 int prefix_len = subtype_info - name;
9508 LONGEST L, U;
9509 struct type *type;
9510 char *bounds_str;
9511 int n;
9512
9513 GROW_VECT (name_buf, name_len, prefix_len + 5);
9514 strncpy (name_buf, name, prefix_len);
9515 name_buf[prefix_len] = '\0';
9516
9517 subtype_info += 5;
9518 bounds_str = strchr (subtype_info, '_');
9519 n = 1;
9520
d2e4a39e 9521 if (*subtype_info == 'L')
4c4b4cd2
PH
9522 {
9523 if (!ada_scan_number (bounds_str, n, &L, &n)
9524 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
9525 return raw_type;
9526 if (bounds_str[n] == '_')
9527 n += 2;
9528 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
9529 n += 1;
9530 subtype_info += 1;
9531 }
d2e4a39e 9532 else
4c4b4cd2
PH
9533 {
9534 int ok;
9535 strcpy (name_buf + prefix_len, "___L");
9536 L = get_int_var_value (name_buf, &ok);
9537 if (!ok)
9538 {
323e0a4a 9539 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
9540 L = 1;
9541 }
9542 }
14f9c5c9 9543
d2e4a39e 9544 if (*subtype_info == 'U')
4c4b4cd2
PH
9545 {
9546 if (!ada_scan_number (bounds_str, n, &U, &n)
9547 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
9548 return raw_type;
9549 }
d2e4a39e 9550 else
4c4b4cd2
PH
9551 {
9552 int ok;
9553 strcpy (name_buf + prefix_len, "___U");
9554 U = get_int_var_value (name_buf, &ok);
9555 if (!ok)
9556 {
323e0a4a 9557 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
9558 U = L;
9559 }
9560 }
14f9c5c9 9561
d2e4a39e 9562 if (objfile == NULL)
4c4b4cd2 9563 objfile = TYPE_OBJFILE (base_type);
14f9c5c9 9564 type = create_range_type (alloc_type (objfile), base_type, L, U);
d2e4a39e 9565 TYPE_NAME (type) = name;
14f9c5c9
AS
9566 return type;
9567 }
9568}
9569
4c4b4cd2
PH
9570/* True iff NAME is the name of a range type. */
9571
14f9c5c9 9572int
d2e4a39e 9573ada_is_range_type_name (const char *name)
14f9c5c9
AS
9574{
9575 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 9576}
14f9c5c9 9577\f
d2e4a39e 9578
4c4b4cd2
PH
9579 /* Modular types */
9580
9581/* True iff TYPE is an Ada modular type. */
14f9c5c9 9582
14f9c5c9 9583int
d2e4a39e 9584ada_is_modular_type (struct type *type)
14f9c5c9 9585{
4c4b4cd2 9586 struct type *subranged_type = base_type (type);
14f9c5c9
AS
9587
9588 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
4c4b4cd2
PH
9589 && TYPE_CODE (subranged_type) != TYPE_CODE_ENUM
9590 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
9591}
9592
4c4b4cd2
PH
9593/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9594
61ee279c 9595ULONGEST
d2e4a39e 9596ada_modulus (struct type * type)
14f9c5c9 9597{
61ee279c 9598 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 9599}
d2e4a39e 9600\f
f7f9143b
JB
9601
9602/* Ada exception catchpoint support:
9603 ---------------------------------
9604
9605 We support 3 kinds of exception catchpoints:
9606 . catchpoints on Ada exceptions
9607 . catchpoints on unhandled Ada exceptions
9608 . catchpoints on failed assertions
9609
9610 Exceptions raised during failed assertions, or unhandled exceptions
9611 could perfectly be caught with the general catchpoint on Ada exceptions.
9612 However, we can easily differentiate these two special cases, and having
9613 the option to distinguish these two cases from the rest can be useful
9614 to zero-in on certain situations.
9615
9616 Exception catchpoints are a specialized form of breakpoint,
9617 since they rely on inserting breakpoints inside known routines
9618 of the GNAT runtime. The implementation therefore uses a standard
9619 breakpoint structure of the BP_BREAKPOINT type, but with its own set
9620 of breakpoint_ops.
9621
0259addd
JB
9622 Support in the runtime for exception catchpoints have been changed
9623 a few times already, and these changes affect the implementation
9624 of these catchpoints. In order to be able to support several
9625 variants of the runtime, we use a sniffer that will determine
9626 the runtime variant used by the program being debugged.
9627
f7f9143b
JB
9628 At this time, we do not support the use of conditions on Ada exception
9629 catchpoints. The COND and COND_STRING fields are therefore set
9630 to NULL (most of the time, see below).
9631
9632 Conditions where EXP_STRING, COND, and COND_STRING are used:
9633
9634 When a user specifies the name of a specific exception in the case
9635 of catchpoints on Ada exceptions, we store the name of that exception
9636 in the EXP_STRING. We then translate this request into an actual
9637 condition stored in COND_STRING, and then parse it into an expression
9638 stored in COND. */
9639
9640/* The different types of catchpoints that we introduced for catching
9641 Ada exceptions. */
9642
9643enum exception_catchpoint_kind
9644{
9645 ex_catch_exception,
9646 ex_catch_exception_unhandled,
9647 ex_catch_assert
9648};
9649
0259addd
JB
9650typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
9651
9652/* A structure that describes how to support exception catchpoints
9653 for a given executable. */
9654
9655struct exception_support_info
9656{
9657 /* The name of the symbol to break on in order to insert
9658 a catchpoint on exceptions. */
9659 const char *catch_exception_sym;
9660
9661 /* The name of the symbol to break on in order to insert
9662 a catchpoint on unhandled exceptions. */
9663 const char *catch_exception_unhandled_sym;
9664
9665 /* The name of the symbol to break on in order to insert
9666 a catchpoint on failed assertions. */
9667 const char *catch_assert_sym;
9668
9669 /* Assuming that the inferior just triggered an unhandled exception
9670 catchpoint, this function is responsible for returning the address
9671 in inferior memory where the name of that exception is stored.
9672 Return zero if the address could not be computed. */
9673 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
9674};
9675
9676static CORE_ADDR ada_unhandled_exception_name_addr (void);
9677static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
9678
9679/* The following exception support info structure describes how to
9680 implement exception catchpoints with the latest version of the
9681 Ada runtime (as of 2007-03-06). */
9682
9683static const struct exception_support_info default_exception_support_info =
9684{
9685 "__gnat_debug_raise_exception", /* catch_exception_sym */
9686 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9687 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9688 ada_unhandled_exception_name_addr
9689};
9690
9691/* The following exception support info structure describes how to
9692 implement exception catchpoints with a slightly older version
9693 of the Ada runtime. */
9694
9695static const struct exception_support_info exception_support_info_fallback =
9696{
9697 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
9698 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9699 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9700 ada_unhandled_exception_name_addr_from_raise
9701};
9702
9703/* For each executable, we sniff which exception info structure to use
9704 and cache it in the following global variable. */
9705
9706static const struct exception_support_info *exception_info = NULL;
9707
9708/* Inspect the Ada runtime and determine which exception info structure
9709 should be used to provide support for exception catchpoints.
9710
9711 This function will always set exception_info, or raise an error. */
9712
9713static void
9714ada_exception_support_info_sniffer (void)
9715{
9716 struct symbol *sym;
9717
9718 /* If the exception info is already known, then no need to recompute it. */
9719 if (exception_info != NULL)
9720 return;
9721
9722 /* Check the latest (default) exception support info. */
9723 sym = standard_lookup (default_exception_support_info.catch_exception_sym,
9724 NULL, VAR_DOMAIN);
9725 if (sym != NULL)
9726 {
9727 exception_info = &default_exception_support_info;
9728 return;
9729 }
9730
9731 /* Try our fallback exception suport info. */
9732 sym = standard_lookup (exception_support_info_fallback.catch_exception_sym,
9733 NULL, VAR_DOMAIN);
9734 if (sym != NULL)
9735 {
9736 exception_info = &exception_support_info_fallback;
9737 return;
9738 }
9739
9740 /* Sometimes, it is normal for us to not be able to find the routine
9741 we are looking for. This happens when the program is linked with
9742 the shared version of the GNAT runtime, and the program has not been
9743 started yet. Inform the user of these two possible causes if
9744 applicable. */
9745
9746 if (ada_update_initial_language (language_unknown, NULL) != language_ada)
9747 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
9748
9749 /* If the symbol does not exist, then check that the program is
9750 already started, to make sure that shared libraries have been
9751 loaded. If it is not started, this may mean that the symbol is
9752 in a shared library. */
9753
9754 if (ptid_get_pid (inferior_ptid) == 0)
9755 error (_("Unable to insert catchpoint. Try to start the program first."));
9756
9757 /* At this point, we know that we are debugging an Ada program and
9758 that the inferior has been started, but we still are not able to
9759 find the run-time symbols. That can mean that we are in
9760 configurable run time mode, or that a-except as been optimized
9761 out by the linker... In any case, at this point it is not worth
9762 supporting this feature. */
9763
9764 error (_("Cannot insert catchpoints in this configuration."));
9765}
9766
9767/* An observer of "executable_changed" events.
9768 Its role is to clear certain cached values that need to be recomputed
9769 each time a new executable is loaded by GDB. */
9770
9771static void
781b42b0 9772ada_executable_changed_observer (void)
0259addd
JB
9773{
9774 /* If the executable changed, then it is possible that the Ada runtime
9775 is different. So we need to invalidate the exception support info
9776 cache. */
9777 exception_info = NULL;
9778}
9779
f7f9143b
JB
9780/* Return the name of the function at PC, NULL if could not find it.
9781 This function only checks the debugging information, not the symbol
9782 table. */
9783
9784static char *
9785function_name_from_pc (CORE_ADDR pc)
9786{
9787 char *func_name;
9788
9789 if (!find_pc_partial_function (pc, &func_name, NULL, NULL))
9790 return NULL;
9791
9792 return func_name;
9793}
9794
9795/* True iff FRAME is very likely to be that of a function that is
9796 part of the runtime system. This is all very heuristic, but is
9797 intended to be used as advice as to what frames are uninteresting
9798 to most users. */
9799
9800static int
9801is_known_support_routine (struct frame_info *frame)
9802{
4ed6b5be 9803 struct symtab_and_line sal;
f7f9143b
JB
9804 char *func_name;
9805 int i;
f7f9143b 9806
4ed6b5be
JB
9807 /* If this code does not have any debugging information (no symtab),
9808 This cannot be any user code. */
f7f9143b 9809
4ed6b5be 9810 find_frame_sal (frame, &sal);
f7f9143b
JB
9811 if (sal.symtab == NULL)
9812 return 1;
9813
4ed6b5be
JB
9814 /* If there is a symtab, but the associated source file cannot be
9815 located, then assume this is not user code: Selecting a frame
9816 for which we cannot display the code would not be very helpful
9817 for the user. This should also take care of case such as VxWorks
9818 where the kernel has some debugging info provided for a few units. */
f7f9143b 9819
9bbc9174 9820 if (symtab_to_fullname (sal.symtab) == NULL)
f7f9143b
JB
9821 return 1;
9822
4ed6b5be
JB
9823 /* Check the unit filename againt the Ada runtime file naming.
9824 We also check the name of the objfile against the name of some
9825 known system libraries that sometimes come with debugging info
9826 too. */
9827
f7f9143b
JB
9828 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
9829 {
9830 re_comp (known_runtime_file_name_patterns[i]);
9831 if (re_exec (sal.symtab->filename))
9832 return 1;
4ed6b5be
JB
9833 if (sal.symtab->objfile != NULL
9834 && re_exec (sal.symtab->objfile->name))
9835 return 1;
f7f9143b
JB
9836 }
9837
4ed6b5be 9838 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 9839
4ed6b5be 9840 func_name = function_name_from_pc (get_frame_address_in_block (frame));
f7f9143b
JB
9841 if (func_name == NULL)
9842 return 1;
9843
9844 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
9845 {
9846 re_comp (known_auxiliary_function_name_patterns[i]);
9847 if (re_exec (func_name))
9848 return 1;
9849 }
9850
9851 return 0;
9852}
9853
9854/* Find the first frame that contains debugging information and that is not
9855 part of the Ada run-time, starting from FI and moving upward. */
9856
9857static void
9858ada_find_printable_frame (struct frame_info *fi)
9859{
9860 for (; fi != NULL; fi = get_prev_frame (fi))
9861 {
9862 if (!is_known_support_routine (fi))
9863 {
9864 select_frame (fi);
9865 break;
9866 }
9867 }
9868
9869}
9870
9871/* Assuming that the inferior just triggered an unhandled exception
9872 catchpoint, return the address in inferior memory where the name
9873 of the exception is stored.
9874
9875 Return zero if the address could not be computed. */
9876
9877static CORE_ADDR
9878ada_unhandled_exception_name_addr (void)
0259addd
JB
9879{
9880 return parse_and_eval_address ("e.full_name");
9881}
9882
9883/* Same as ada_unhandled_exception_name_addr, except that this function
9884 should be used when the inferior uses an older version of the runtime,
9885 where the exception name needs to be extracted from a specific frame
9886 several frames up in the callstack. */
9887
9888static CORE_ADDR
9889ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
9890{
9891 int frame_level;
9892 struct frame_info *fi;
9893
9894 /* To determine the name of this exception, we need to select
9895 the frame corresponding to RAISE_SYM_NAME. This frame is
9896 at least 3 levels up, so we simply skip the first 3 frames
9897 without checking the name of their associated function. */
9898 fi = get_current_frame ();
9899 for (frame_level = 0; frame_level < 3; frame_level += 1)
9900 if (fi != NULL)
9901 fi = get_prev_frame (fi);
9902
9903 while (fi != NULL)
9904 {
9905 const char *func_name =
9906 function_name_from_pc (get_frame_address_in_block (fi));
9907 if (func_name != NULL
0259addd 9908 && strcmp (func_name, exception_info->catch_exception_sym) == 0)
f7f9143b
JB
9909 break; /* We found the frame we were looking for... */
9910 fi = get_prev_frame (fi);
9911 }
9912
9913 if (fi == NULL)
9914 return 0;
9915
9916 select_frame (fi);
9917 return parse_and_eval_address ("id.full_name");
9918}
9919
9920/* Assuming the inferior just triggered an Ada exception catchpoint
9921 (of any type), return the address in inferior memory where the name
9922 of the exception is stored, if applicable.
9923
9924 Return zero if the address could not be computed, or if not relevant. */
9925
9926static CORE_ADDR
9927ada_exception_name_addr_1 (enum exception_catchpoint_kind ex,
9928 struct breakpoint *b)
9929{
9930 switch (ex)
9931 {
9932 case ex_catch_exception:
9933 return (parse_and_eval_address ("e.full_name"));
9934 break;
9935
9936 case ex_catch_exception_unhandled:
0259addd 9937 return exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
9938 break;
9939
9940 case ex_catch_assert:
9941 return 0; /* Exception name is not relevant in this case. */
9942 break;
9943
9944 default:
9945 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
9946 break;
9947 }
9948
9949 return 0; /* Should never be reached. */
9950}
9951
9952/* Same as ada_exception_name_addr_1, except that it intercepts and contains
9953 any error that ada_exception_name_addr_1 might cause to be thrown.
9954 When an error is intercepted, a warning with the error message is printed,
9955 and zero is returned. */
9956
9957static CORE_ADDR
9958ada_exception_name_addr (enum exception_catchpoint_kind ex,
9959 struct breakpoint *b)
9960{
9961 struct gdb_exception e;
9962 CORE_ADDR result = 0;
9963
9964 TRY_CATCH (e, RETURN_MASK_ERROR)
9965 {
9966 result = ada_exception_name_addr_1 (ex, b);
9967 }
9968
9969 if (e.reason < 0)
9970 {
9971 warning (_("failed to get exception name: %s"), e.message);
9972 return 0;
9973 }
9974
9975 return result;
9976}
9977
9978/* Implement the PRINT_IT method in the breakpoint_ops structure
9979 for all exception catchpoint kinds. */
9980
9981static enum print_stop_action
9982print_it_exception (enum exception_catchpoint_kind ex, struct breakpoint *b)
9983{
9984 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
9985 char exception_name[256];
9986
9987 if (addr != 0)
9988 {
9989 read_memory (addr, exception_name, sizeof (exception_name) - 1);
9990 exception_name [sizeof (exception_name) - 1] = '\0';
9991 }
9992
9993 ada_find_printable_frame (get_current_frame ());
9994
9995 annotate_catchpoint (b->number);
9996 switch (ex)
9997 {
9998 case ex_catch_exception:
9999 if (addr != 0)
10000 printf_filtered (_("\nCatchpoint %d, %s at "),
10001 b->number, exception_name);
10002 else
10003 printf_filtered (_("\nCatchpoint %d, exception at "), b->number);
10004 break;
10005 case ex_catch_exception_unhandled:
10006 if (addr != 0)
10007 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
10008 b->number, exception_name);
10009 else
10010 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
10011 b->number);
10012 break;
10013 case ex_catch_assert:
10014 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
10015 b->number);
10016 break;
10017 }
10018
10019 return PRINT_SRC_AND_LOC;
10020}
10021
10022/* Implement the PRINT_ONE method in the breakpoint_ops structure
10023 for all exception catchpoint kinds. */
10024
10025static void
10026print_one_exception (enum exception_catchpoint_kind ex,
10027 struct breakpoint *b, CORE_ADDR *last_addr)
10028{
10029 if (addressprint)
10030 {
10031 annotate_field (4);
10032 ui_out_field_core_addr (uiout, "addr", b->loc->address);
10033 }
10034
10035 annotate_field (5);
10036 *last_addr = b->loc->address;
10037 switch (ex)
10038 {
10039 case ex_catch_exception:
10040 if (b->exp_string != NULL)
10041 {
10042 char *msg = xstrprintf (_("`%s' Ada exception"), b->exp_string);
10043
10044 ui_out_field_string (uiout, "what", msg);
10045 xfree (msg);
10046 }
10047 else
10048 ui_out_field_string (uiout, "what", "all Ada exceptions");
10049
10050 break;
10051
10052 case ex_catch_exception_unhandled:
10053 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
10054 break;
10055
10056 case ex_catch_assert:
10057 ui_out_field_string (uiout, "what", "failed Ada assertions");
10058 break;
10059
10060 default:
10061 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10062 break;
10063 }
10064}
10065
10066/* Implement the PRINT_MENTION method in the breakpoint_ops structure
10067 for all exception catchpoint kinds. */
10068
10069static void
10070print_mention_exception (enum exception_catchpoint_kind ex,
10071 struct breakpoint *b)
10072{
10073 switch (ex)
10074 {
10075 case ex_catch_exception:
10076 if (b->exp_string != NULL)
10077 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
10078 b->number, b->exp_string);
10079 else
10080 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b->number);
10081
10082 break;
10083
10084 case ex_catch_exception_unhandled:
10085 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
10086 b->number);
10087 break;
10088
10089 case ex_catch_assert:
10090 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b->number);
10091 break;
10092
10093 default:
10094 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10095 break;
10096 }
10097}
10098
10099/* Virtual table for "catch exception" breakpoints. */
10100
10101static enum print_stop_action
10102print_it_catch_exception (struct breakpoint *b)
10103{
10104 return print_it_exception (ex_catch_exception, b);
10105}
10106
10107static void
10108print_one_catch_exception (struct breakpoint *b, CORE_ADDR *last_addr)
10109{
10110 print_one_exception (ex_catch_exception, b, last_addr);
10111}
10112
10113static void
10114print_mention_catch_exception (struct breakpoint *b)
10115{
10116 print_mention_exception (ex_catch_exception, b);
10117}
10118
10119static struct breakpoint_ops catch_exception_breakpoint_ops =
10120{
10121 print_it_catch_exception,
10122 print_one_catch_exception,
10123 print_mention_catch_exception
10124};
10125
10126/* Virtual table for "catch exception unhandled" breakpoints. */
10127
10128static enum print_stop_action
10129print_it_catch_exception_unhandled (struct breakpoint *b)
10130{
10131 return print_it_exception (ex_catch_exception_unhandled, b);
10132}
10133
10134static void
10135print_one_catch_exception_unhandled (struct breakpoint *b, CORE_ADDR *last_addr)
10136{
10137 print_one_exception (ex_catch_exception_unhandled, b, last_addr);
10138}
10139
10140static void
10141print_mention_catch_exception_unhandled (struct breakpoint *b)
10142{
10143 print_mention_exception (ex_catch_exception_unhandled, b);
10144}
10145
10146static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops = {
10147 print_it_catch_exception_unhandled,
10148 print_one_catch_exception_unhandled,
10149 print_mention_catch_exception_unhandled
10150};
10151
10152/* Virtual table for "catch assert" breakpoints. */
10153
10154static enum print_stop_action
10155print_it_catch_assert (struct breakpoint *b)
10156{
10157 return print_it_exception (ex_catch_assert, b);
10158}
10159
10160static void
10161print_one_catch_assert (struct breakpoint *b, CORE_ADDR *last_addr)
10162{
10163 print_one_exception (ex_catch_assert, b, last_addr);
10164}
10165
10166static void
10167print_mention_catch_assert (struct breakpoint *b)
10168{
10169 print_mention_exception (ex_catch_assert, b);
10170}
10171
10172static struct breakpoint_ops catch_assert_breakpoint_ops = {
10173 print_it_catch_assert,
10174 print_one_catch_assert,
10175 print_mention_catch_assert
10176};
10177
10178/* Return non-zero if B is an Ada exception catchpoint. */
10179
10180int
10181ada_exception_catchpoint_p (struct breakpoint *b)
10182{
10183 return (b->ops == &catch_exception_breakpoint_ops
10184 || b->ops == &catch_exception_unhandled_breakpoint_ops
10185 || b->ops == &catch_assert_breakpoint_ops);
10186}
10187
f7f9143b
JB
10188/* Return a newly allocated copy of the first space-separated token
10189 in ARGSP, and then adjust ARGSP to point immediately after that
10190 token.
10191
10192 Return NULL if ARGPS does not contain any more tokens. */
10193
10194static char *
10195ada_get_next_arg (char **argsp)
10196{
10197 char *args = *argsp;
10198 char *end;
10199 char *result;
10200
10201 /* Skip any leading white space. */
10202
10203 while (isspace (*args))
10204 args++;
10205
10206 if (args[0] == '\0')
10207 return NULL; /* No more arguments. */
10208
10209 /* Find the end of the current argument. */
10210
10211 end = args;
10212 while (*end != '\0' && !isspace (*end))
10213 end++;
10214
10215 /* Adjust ARGSP to point to the start of the next argument. */
10216
10217 *argsp = end;
10218
10219 /* Make a copy of the current argument and return it. */
10220
10221 result = xmalloc (end - args + 1);
10222 strncpy (result, args, end - args);
10223 result[end - args] = '\0';
10224
10225 return result;
10226}
10227
10228/* Split the arguments specified in a "catch exception" command.
10229 Set EX to the appropriate catchpoint type.
10230 Set EXP_STRING to the name of the specific exception if
10231 specified by the user. */
10232
10233static void
10234catch_ada_exception_command_split (char *args,
10235 enum exception_catchpoint_kind *ex,
10236 char **exp_string)
10237{
10238 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
10239 char *exception_name;
10240
10241 exception_name = ada_get_next_arg (&args);
10242 make_cleanup (xfree, exception_name);
10243
10244 /* Check that we do not have any more arguments. Anything else
10245 is unexpected. */
10246
10247 while (isspace (*args))
10248 args++;
10249
10250 if (args[0] != '\0')
10251 error (_("Junk at end of expression"));
10252
10253 discard_cleanups (old_chain);
10254
10255 if (exception_name == NULL)
10256 {
10257 /* Catch all exceptions. */
10258 *ex = ex_catch_exception;
10259 *exp_string = NULL;
10260 }
10261 else if (strcmp (exception_name, "unhandled") == 0)
10262 {
10263 /* Catch unhandled exceptions. */
10264 *ex = ex_catch_exception_unhandled;
10265 *exp_string = NULL;
10266 }
10267 else
10268 {
10269 /* Catch a specific exception. */
10270 *ex = ex_catch_exception;
10271 *exp_string = exception_name;
10272 }
10273}
10274
10275/* Return the name of the symbol on which we should break in order to
10276 implement a catchpoint of the EX kind. */
10277
10278static const char *
10279ada_exception_sym_name (enum exception_catchpoint_kind ex)
10280{
0259addd
JB
10281 gdb_assert (exception_info != NULL);
10282
f7f9143b
JB
10283 switch (ex)
10284 {
10285 case ex_catch_exception:
0259addd 10286 return (exception_info->catch_exception_sym);
f7f9143b
JB
10287 break;
10288 case ex_catch_exception_unhandled:
0259addd 10289 return (exception_info->catch_exception_unhandled_sym);
f7f9143b
JB
10290 break;
10291 case ex_catch_assert:
0259addd 10292 return (exception_info->catch_assert_sym);
f7f9143b
JB
10293 break;
10294 default:
10295 internal_error (__FILE__, __LINE__,
10296 _("unexpected catchpoint kind (%d)"), ex);
10297 }
10298}
10299
10300/* Return the breakpoint ops "virtual table" used for catchpoints
10301 of the EX kind. */
10302
10303static struct breakpoint_ops *
4b9eee8c 10304ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex)
f7f9143b
JB
10305{
10306 switch (ex)
10307 {
10308 case ex_catch_exception:
10309 return (&catch_exception_breakpoint_ops);
10310 break;
10311 case ex_catch_exception_unhandled:
10312 return (&catch_exception_unhandled_breakpoint_ops);
10313 break;
10314 case ex_catch_assert:
10315 return (&catch_assert_breakpoint_ops);
10316 break;
10317 default:
10318 internal_error (__FILE__, __LINE__,
10319 _("unexpected catchpoint kind (%d)"), ex);
10320 }
10321}
10322
10323/* Return the condition that will be used to match the current exception
10324 being raised with the exception that the user wants to catch. This
10325 assumes that this condition is used when the inferior just triggered
10326 an exception catchpoint.
10327
10328 The string returned is a newly allocated string that needs to be
10329 deallocated later. */
10330
10331static char *
10332ada_exception_catchpoint_cond_string (const char *exp_string)
10333{
10334 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string);
10335}
10336
10337/* Return the expression corresponding to COND_STRING evaluated at SAL. */
10338
10339static struct expression *
10340ada_parse_catchpoint_condition (char *cond_string,
10341 struct symtab_and_line sal)
10342{
10343 return (parse_exp_1 (&cond_string, block_for_pc (sal.pc), 0));
10344}
10345
10346/* Return the symtab_and_line that should be used to insert an exception
10347 catchpoint of the TYPE kind.
10348
10349 EX_STRING should contain the name of a specific exception
10350 that the catchpoint should catch, or NULL otherwise.
10351
10352 The idea behind all the remaining parameters is that their names match
10353 the name of certain fields in the breakpoint structure that are used to
10354 handle exception catchpoints. This function returns the value to which
10355 these fields should be set, depending on the type of catchpoint we need
10356 to create.
10357
10358 If COND and COND_STRING are both non-NULL, any value they might
10359 hold will be free'ed, and then replaced by newly allocated ones.
10360 These parameters are left untouched otherwise. */
10361
10362static struct symtab_and_line
10363ada_exception_sal (enum exception_catchpoint_kind ex, char *exp_string,
10364 char **addr_string, char **cond_string,
10365 struct expression **cond, struct breakpoint_ops **ops)
10366{
10367 const char *sym_name;
10368 struct symbol *sym;
10369 struct symtab_and_line sal;
10370
0259addd
JB
10371 /* First, find out which exception support info to use. */
10372 ada_exception_support_info_sniffer ();
10373
10374 /* Then lookup the function on which we will break in order to catch
f7f9143b
JB
10375 the Ada exceptions requested by the user. */
10376
10377 sym_name = ada_exception_sym_name (ex);
10378 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
10379
10380 /* The symbol we're looking up is provided by a unit in the GNAT runtime
10381 that should be compiled with debugging information. As a result, we
10382 expect to find that symbol in the symtabs. If we don't find it, then
10383 the target most likely does not support Ada exceptions, or we cannot
10384 insert exception breakpoints yet, because the GNAT runtime hasn't been
10385 loaded yet. */
10386
10387 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
10388 in such a way that no debugging information is produced for the symbol
10389 we are looking for. In this case, we could search the minimal symbols
10390 as a fall-back mechanism. This would still be operating in degraded
10391 mode, however, as we would still be missing the debugging information
10392 that is needed in order to extract the name of the exception being
10393 raised (this name is printed in the catchpoint message, and is also
10394 used when trying to catch a specific exception). We do not handle
10395 this case for now. */
10396
10397 if (sym == NULL)
0259addd 10398 error (_("Unable to break on '%s' in this configuration."), sym_name);
f7f9143b
JB
10399
10400 /* Make sure that the symbol we found corresponds to a function. */
10401 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
10402 error (_("Symbol \"%s\" is not a function (class = %d)"),
10403 sym_name, SYMBOL_CLASS (sym));
10404
10405 sal = find_function_start_sal (sym, 1);
10406
10407 /* Set ADDR_STRING. */
10408
10409 *addr_string = xstrdup (sym_name);
10410
10411 /* Set the COND and COND_STRING (if not NULL). */
10412
10413 if (cond_string != NULL && cond != NULL)
10414 {
10415 if (*cond_string != NULL)
10416 {
10417 xfree (*cond_string);
10418 *cond_string = NULL;
10419 }
10420 if (*cond != NULL)
10421 {
10422 xfree (*cond);
10423 *cond = NULL;
10424 }
10425 if (exp_string != NULL)
10426 {
10427 *cond_string = ada_exception_catchpoint_cond_string (exp_string);
10428 *cond = ada_parse_catchpoint_condition (*cond_string, sal);
10429 }
10430 }
10431
10432 /* Set OPS. */
4b9eee8c 10433 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b
JB
10434
10435 return sal;
10436}
10437
10438/* Parse the arguments (ARGS) of the "catch exception" command.
10439
10440 Set TYPE to the appropriate exception catchpoint type.
10441 If the user asked the catchpoint to catch only a specific
10442 exception, then save the exception name in ADDR_STRING.
10443
10444 See ada_exception_sal for a description of all the remaining
10445 function arguments of this function. */
10446
10447struct symtab_and_line
10448ada_decode_exception_location (char *args, char **addr_string,
10449 char **exp_string, char **cond_string,
10450 struct expression **cond,
10451 struct breakpoint_ops **ops)
10452{
10453 enum exception_catchpoint_kind ex;
10454
10455 catch_ada_exception_command_split (args, &ex, exp_string);
10456 return ada_exception_sal (ex, *exp_string, addr_string, cond_string,
10457 cond, ops);
10458}
10459
10460struct symtab_and_line
10461ada_decode_assert_location (char *args, char **addr_string,
10462 struct breakpoint_ops **ops)
10463{
10464 /* Check that no argument where provided at the end of the command. */
10465
10466 if (args != NULL)
10467 {
10468 while (isspace (*args))
10469 args++;
10470 if (*args != '\0')
10471 error (_("Junk at end of arguments."));
10472 }
10473
10474 return ada_exception_sal (ex_catch_assert, NULL, addr_string, NULL, NULL,
10475 ops);
10476}
10477
4c4b4cd2
PH
10478 /* Operators */
10479/* Information about operators given special treatment in functions
10480 below. */
10481/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
10482
10483#define ADA_OPERATORS \
10484 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
10485 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
10486 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
10487 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
10488 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
10489 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
10490 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
10491 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
10492 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
10493 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
10494 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
10495 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
10496 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
10497 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
10498 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
10499 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
10500 OP_DEFN (OP_OTHERS, 1, 1, 0) \
10501 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
10502 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
10503
10504static void
10505ada_operator_length (struct expression *exp, int pc, int *oplenp, int *argsp)
10506{
10507 switch (exp->elts[pc - 1].opcode)
10508 {
76a01679 10509 default:
4c4b4cd2
PH
10510 operator_length_standard (exp, pc, oplenp, argsp);
10511 break;
10512
10513#define OP_DEFN(op, len, args, binop) \
10514 case op: *oplenp = len; *argsp = args; break;
10515 ADA_OPERATORS;
10516#undef OP_DEFN
52ce6436
PH
10517
10518 case OP_AGGREGATE:
10519 *oplenp = 3;
10520 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
10521 break;
10522
10523 case OP_CHOICES:
10524 *oplenp = 3;
10525 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
10526 break;
4c4b4cd2
PH
10527 }
10528}
10529
10530static char *
10531ada_op_name (enum exp_opcode opcode)
10532{
10533 switch (opcode)
10534 {
76a01679 10535 default:
4c4b4cd2 10536 return op_name_standard (opcode);
52ce6436 10537
4c4b4cd2
PH
10538#define OP_DEFN(op, len, args, binop) case op: return #op;
10539 ADA_OPERATORS;
10540#undef OP_DEFN
52ce6436
PH
10541
10542 case OP_AGGREGATE:
10543 return "OP_AGGREGATE";
10544 case OP_CHOICES:
10545 return "OP_CHOICES";
10546 case OP_NAME:
10547 return "OP_NAME";
4c4b4cd2
PH
10548 }
10549}
10550
10551/* As for operator_length, but assumes PC is pointing at the first
10552 element of the operator, and gives meaningful results only for the
52ce6436 10553 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
10554
10555static void
76a01679
JB
10556ada_forward_operator_length (struct expression *exp, int pc,
10557 int *oplenp, int *argsp)
4c4b4cd2 10558{
76a01679 10559 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
10560 {
10561 default:
10562 *oplenp = *argsp = 0;
10563 break;
52ce6436 10564
4c4b4cd2
PH
10565#define OP_DEFN(op, len, args, binop) \
10566 case op: *oplenp = len; *argsp = args; break;
10567 ADA_OPERATORS;
10568#undef OP_DEFN
52ce6436
PH
10569
10570 case OP_AGGREGATE:
10571 *oplenp = 3;
10572 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
10573 break;
10574
10575 case OP_CHOICES:
10576 *oplenp = 3;
10577 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
10578 break;
10579
10580 case OP_STRING:
10581 case OP_NAME:
10582 {
10583 int len = longest_to_int (exp->elts[pc + 1].longconst);
10584 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
10585 *argsp = 0;
10586 break;
10587 }
4c4b4cd2
PH
10588 }
10589}
10590
10591static int
10592ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
10593{
10594 enum exp_opcode op = exp->elts[elt].opcode;
10595 int oplen, nargs;
10596 int pc = elt;
10597 int i;
76a01679 10598
4c4b4cd2
PH
10599 ada_forward_operator_length (exp, elt, &oplen, &nargs);
10600
76a01679 10601 switch (op)
4c4b4cd2 10602 {
76a01679 10603 /* Ada attributes ('Foo). */
4c4b4cd2
PH
10604 case OP_ATR_FIRST:
10605 case OP_ATR_LAST:
10606 case OP_ATR_LENGTH:
10607 case OP_ATR_IMAGE:
10608 case OP_ATR_MAX:
10609 case OP_ATR_MIN:
10610 case OP_ATR_MODULUS:
10611 case OP_ATR_POS:
10612 case OP_ATR_SIZE:
10613 case OP_ATR_TAG:
10614 case OP_ATR_VAL:
10615 break;
10616
10617 case UNOP_IN_RANGE:
10618 case UNOP_QUAL:
323e0a4a
AC
10619 /* XXX: gdb_sprint_host_address, type_sprint */
10620 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
10621 gdb_print_host_address (exp->elts[pc + 1].type, stream);
10622 fprintf_filtered (stream, " (");
10623 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
10624 fprintf_filtered (stream, ")");
10625 break;
10626 case BINOP_IN_BOUNDS:
52ce6436
PH
10627 fprintf_filtered (stream, " (%d)",
10628 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
10629 break;
10630 case TERNOP_IN_RANGE:
10631 break;
10632
52ce6436
PH
10633 case OP_AGGREGATE:
10634 case OP_OTHERS:
10635 case OP_DISCRETE_RANGE:
10636 case OP_POSITIONAL:
10637 case OP_CHOICES:
10638 break;
10639
10640 case OP_NAME:
10641 case OP_STRING:
10642 {
10643 char *name = &exp->elts[elt + 2].string;
10644 int len = longest_to_int (exp->elts[elt + 1].longconst);
10645 fprintf_filtered (stream, "Text: `%.*s'", len, name);
10646 break;
10647 }
10648
4c4b4cd2
PH
10649 default:
10650 return dump_subexp_body_standard (exp, stream, elt);
10651 }
10652
10653 elt += oplen;
10654 for (i = 0; i < nargs; i += 1)
10655 elt = dump_subexp (exp, stream, elt);
10656
10657 return elt;
10658}
10659
10660/* The Ada extension of print_subexp (q.v.). */
10661
76a01679
JB
10662static void
10663ada_print_subexp (struct expression *exp, int *pos,
10664 struct ui_file *stream, enum precedence prec)
4c4b4cd2 10665{
52ce6436 10666 int oplen, nargs, i;
4c4b4cd2
PH
10667 int pc = *pos;
10668 enum exp_opcode op = exp->elts[pc].opcode;
10669
10670 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10671
52ce6436 10672 *pos += oplen;
4c4b4cd2
PH
10673 switch (op)
10674 {
10675 default:
52ce6436 10676 *pos -= oplen;
4c4b4cd2
PH
10677 print_subexp_standard (exp, pos, stream, prec);
10678 return;
10679
10680 case OP_VAR_VALUE:
4c4b4cd2
PH
10681 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
10682 return;
10683
10684 case BINOP_IN_BOUNDS:
323e0a4a 10685 /* XXX: sprint_subexp */
4c4b4cd2 10686 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 10687 fputs_filtered (" in ", stream);
4c4b4cd2 10688 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 10689 fputs_filtered ("'range", stream);
4c4b4cd2 10690 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
10691 fprintf_filtered (stream, "(%ld)",
10692 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
10693 return;
10694
10695 case TERNOP_IN_RANGE:
4c4b4cd2 10696 if (prec >= PREC_EQUAL)
76a01679 10697 fputs_filtered ("(", stream);
323e0a4a 10698 /* XXX: sprint_subexp */
4c4b4cd2 10699 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 10700 fputs_filtered (" in ", stream);
4c4b4cd2
PH
10701 print_subexp (exp, pos, stream, PREC_EQUAL);
10702 fputs_filtered (" .. ", stream);
10703 print_subexp (exp, pos, stream, PREC_EQUAL);
10704 if (prec >= PREC_EQUAL)
76a01679
JB
10705 fputs_filtered (")", stream);
10706 return;
4c4b4cd2
PH
10707
10708 case OP_ATR_FIRST:
10709 case OP_ATR_LAST:
10710 case OP_ATR_LENGTH:
10711 case OP_ATR_IMAGE:
10712 case OP_ATR_MAX:
10713 case OP_ATR_MIN:
10714 case OP_ATR_MODULUS:
10715 case OP_ATR_POS:
10716 case OP_ATR_SIZE:
10717 case OP_ATR_TAG:
10718 case OP_ATR_VAL:
4c4b4cd2 10719 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
10720 {
10721 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
10722 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0);
10723 *pos += 3;
10724 }
4c4b4cd2 10725 else
76a01679 10726 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
10727 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
10728 if (nargs > 1)
76a01679
JB
10729 {
10730 int tem;
10731 for (tem = 1; tem < nargs; tem += 1)
10732 {
10733 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
10734 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
10735 }
10736 fputs_filtered (")", stream);
10737 }
4c4b4cd2 10738 return;
14f9c5c9 10739
4c4b4cd2 10740 case UNOP_QUAL:
4c4b4cd2
PH
10741 type_print (exp->elts[pc + 1].type, "", stream, 0);
10742 fputs_filtered ("'(", stream);
10743 print_subexp (exp, pos, stream, PREC_PREFIX);
10744 fputs_filtered (")", stream);
10745 return;
14f9c5c9 10746
4c4b4cd2 10747 case UNOP_IN_RANGE:
323e0a4a 10748 /* XXX: sprint_subexp */
4c4b4cd2 10749 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 10750 fputs_filtered (" in ", stream);
4c4b4cd2
PH
10751 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0);
10752 return;
52ce6436
PH
10753
10754 case OP_DISCRETE_RANGE:
10755 print_subexp (exp, pos, stream, PREC_SUFFIX);
10756 fputs_filtered ("..", stream);
10757 print_subexp (exp, pos, stream, PREC_SUFFIX);
10758 return;
10759
10760 case OP_OTHERS:
10761 fputs_filtered ("others => ", stream);
10762 print_subexp (exp, pos, stream, PREC_SUFFIX);
10763 return;
10764
10765 case OP_CHOICES:
10766 for (i = 0; i < nargs-1; i += 1)
10767 {
10768 if (i > 0)
10769 fputs_filtered ("|", stream);
10770 print_subexp (exp, pos, stream, PREC_SUFFIX);
10771 }
10772 fputs_filtered (" => ", stream);
10773 print_subexp (exp, pos, stream, PREC_SUFFIX);
10774 return;
10775
10776 case OP_POSITIONAL:
10777 print_subexp (exp, pos, stream, PREC_SUFFIX);
10778 return;
10779
10780 case OP_AGGREGATE:
10781 fputs_filtered ("(", stream);
10782 for (i = 0; i < nargs; i += 1)
10783 {
10784 if (i > 0)
10785 fputs_filtered (", ", stream);
10786 print_subexp (exp, pos, stream, PREC_SUFFIX);
10787 }
10788 fputs_filtered (")", stream);
10789 return;
4c4b4cd2
PH
10790 }
10791}
14f9c5c9
AS
10792
10793/* Table mapping opcodes into strings for printing operators
10794 and precedences of the operators. */
10795
d2e4a39e
AS
10796static const struct op_print ada_op_print_tab[] = {
10797 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
10798 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
10799 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
10800 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
10801 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
10802 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
10803 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
10804 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
10805 {"<=", BINOP_LEQ, PREC_ORDER, 0},
10806 {">=", BINOP_GEQ, PREC_ORDER, 0},
10807 {">", BINOP_GTR, PREC_ORDER, 0},
10808 {"<", BINOP_LESS, PREC_ORDER, 0},
10809 {">>", BINOP_RSH, PREC_SHIFT, 0},
10810 {"<<", BINOP_LSH, PREC_SHIFT, 0},
10811 {"+", BINOP_ADD, PREC_ADD, 0},
10812 {"-", BINOP_SUB, PREC_ADD, 0},
10813 {"&", BINOP_CONCAT, PREC_ADD, 0},
10814 {"*", BINOP_MUL, PREC_MUL, 0},
10815 {"/", BINOP_DIV, PREC_MUL, 0},
10816 {"rem", BINOP_REM, PREC_MUL, 0},
10817 {"mod", BINOP_MOD, PREC_MUL, 0},
10818 {"**", BINOP_EXP, PREC_REPEAT, 0},
10819 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
10820 {"-", UNOP_NEG, PREC_PREFIX, 0},
10821 {"+", UNOP_PLUS, PREC_PREFIX, 0},
10822 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
10823 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
10824 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
10825 {".all", UNOP_IND, PREC_SUFFIX, 1},
10826 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
10827 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
d2e4a39e 10828 {NULL, 0, 0, 0}
14f9c5c9
AS
10829};
10830\f
72d5681a
PH
10831enum ada_primitive_types {
10832 ada_primitive_type_int,
10833 ada_primitive_type_long,
10834 ada_primitive_type_short,
10835 ada_primitive_type_char,
10836 ada_primitive_type_float,
10837 ada_primitive_type_double,
10838 ada_primitive_type_void,
10839 ada_primitive_type_long_long,
10840 ada_primitive_type_long_double,
10841 ada_primitive_type_natural,
10842 ada_primitive_type_positive,
10843 ada_primitive_type_system_address,
10844 nr_ada_primitive_types
10845};
6c038f32
PH
10846
10847static void
d4a9a881 10848ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
10849 struct language_arch_info *lai)
10850{
d4a9a881 10851 const struct builtin_type *builtin = builtin_type (gdbarch);
72d5681a 10852 lai->primitive_type_vector
d4a9a881 10853 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a
PH
10854 struct type *);
10855 lai->primitive_type_vector [ada_primitive_type_int] =
9a76efb6 10856 init_type (TYPE_CODE_INT,
d4a9a881 10857 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
9a76efb6 10858 0, "integer", (struct objfile *) NULL);
72d5681a 10859 lai->primitive_type_vector [ada_primitive_type_long] =
9a76efb6 10860 init_type (TYPE_CODE_INT,
d4a9a881 10861 gdbarch_long_bit (gdbarch) / TARGET_CHAR_BIT,
9a76efb6 10862 0, "long_integer", (struct objfile *) NULL);
72d5681a 10863 lai->primitive_type_vector [ada_primitive_type_short] =
9a76efb6 10864 init_type (TYPE_CODE_INT,
d4a9a881 10865 gdbarch_short_bit (gdbarch) / TARGET_CHAR_BIT,
9a76efb6 10866 0, "short_integer", (struct objfile *) NULL);
61ee279c
PH
10867 lai->string_char_type =
10868 lai->primitive_type_vector [ada_primitive_type_char] =
6c038f32
PH
10869 init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
10870 0, "character", (struct objfile *) NULL);
72d5681a 10871 lai->primitive_type_vector [ada_primitive_type_float] =
ea06eb3d 10872 init_type (TYPE_CODE_FLT,
d4a9a881 10873 gdbarch_float_bit (gdbarch)/ TARGET_CHAR_BIT,
6c038f32 10874 0, "float", (struct objfile *) NULL);
72d5681a 10875 lai->primitive_type_vector [ada_primitive_type_double] =
ea06eb3d 10876 init_type (TYPE_CODE_FLT,
d4a9a881 10877 gdbarch_double_bit (gdbarch) / TARGET_CHAR_BIT,
6c038f32 10878 0, "long_float", (struct objfile *) NULL);
72d5681a 10879 lai->primitive_type_vector [ada_primitive_type_long_long] =
9a76efb6 10880 init_type (TYPE_CODE_INT,
d4a9a881 10881 gdbarch_long_long_bit (gdbarch) / TARGET_CHAR_BIT,
6c038f32 10882 0, "long_long_integer", (struct objfile *) NULL);
72d5681a 10883 lai->primitive_type_vector [ada_primitive_type_long_double] =
ea06eb3d 10884 init_type (TYPE_CODE_FLT,
d4a9a881 10885 gdbarch_double_bit (gdbarch) / TARGET_CHAR_BIT,
6c038f32 10886 0, "long_long_float", (struct objfile *) NULL);
72d5681a 10887 lai->primitive_type_vector [ada_primitive_type_natural] =
9a76efb6 10888 init_type (TYPE_CODE_INT,
d4a9a881 10889 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
9a76efb6 10890 0, "natural", (struct objfile *) NULL);
72d5681a 10891 lai->primitive_type_vector [ada_primitive_type_positive] =
9a76efb6 10892 init_type (TYPE_CODE_INT,
d4a9a881 10893 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
9a76efb6 10894 0, "positive", (struct objfile *) NULL);
72d5681a 10895 lai->primitive_type_vector [ada_primitive_type_void] = builtin->builtin_void;
6c038f32 10896
72d5681a 10897 lai->primitive_type_vector [ada_primitive_type_system_address] =
6c038f32
PH
10898 lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
10899 (struct objfile *) NULL));
72d5681a
PH
10900 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
10901 = "system__address";
6c038f32 10902}
6c038f32
PH
10903\f
10904 /* Language vector */
10905
10906/* Not really used, but needed in the ada_language_defn. */
10907
10908static void
10909emit_char (int c, struct ui_file *stream, int quoter)
10910{
10911 ada_emit_char (c, stream, quoter, 1);
10912}
10913
10914static int
10915parse (void)
10916{
10917 warnings_issued = 0;
10918 return ada_parse ();
10919}
10920
10921static const struct exp_descriptor ada_exp_descriptor = {
10922 ada_print_subexp,
10923 ada_operator_length,
10924 ada_op_name,
10925 ada_dump_subexp_body,
10926 ada_evaluate_subexp
10927};
10928
10929const struct language_defn ada_language_defn = {
10930 "ada", /* Language name */
10931 language_ada,
6c038f32
PH
10932 range_check_off,
10933 type_check_off,
10934 case_sensitive_on, /* Yes, Ada is case-insensitive, but
10935 that's not quite what this means. */
6c038f32
PH
10936 array_row_major,
10937 &ada_exp_descriptor,
10938 parse,
10939 ada_error,
10940 resolve,
10941 ada_printchar, /* Print a character constant */
10942 ada_printstr, /* Function to print string constant */
10943 emit_char, /* Function to print single char (not used) */
6c038f32
PH
10944 ada_print_type, /* Print a type using appropriate syntax */
10945 ada_val_print, /* Print a value using appropriate syntax */
10946 ada_value_print, /* Print a top-level value */
10947 NULL, /* Language specific skip_trampoline */
2b2d9e11 10948 NULL, /* name_of_this */
6c038f32
PH
10949 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
10950 basic_lookup_transparent_type, /* lookup_transparent_type */
10951 ada_la_decode, /* Language specific symbol demangler */
10952 NULL, /* Language specific class_name_from_physname */
10953 ada_op_print_tab, /* expression operators for printing */
10954 0, /* c-style arrays */
10955 1, /* String lower bound */
6c038f32 10956 ada_get_gdb_completer_word_break_characters,
41d27058 10957 ada_make_symbol_completion_list,
72d5681a 10958 ada_language_arch_info,
e79af960 10959 ada_print_array_index,
41f1b697 10960 default_pass_by_reference,
6c038f32
PH
10961 LANG_MAGIC
10962};
10963
d2e4a39e 10964void
6c038f32 10965_initialize_ada_language (void)
14f9c5c9 10966{
6c038f32
PH
10967 add_language (&ada_language_defn);
10968
10969 varsize_limit = 65536;
6c038f32
PH
10970
10971 obstack_init (&symbol_list_obstack);
10972
10973 decoded_names_store = htab_create_alloc
10974 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
10975 NULL, xcalloc, xfree);
6b69afc4
JB
10976
10977 observer_attach_executable_changed (ada_executable_changed_observer);
14f9c5c9 10978}