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