]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
use bound_minsym as result for lookup_minimal_symbol et al
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
6e681866 1/* Ada language support routines for GDB, the GNU debugger.
10a2c479 2
ecd75fc8 3 Copyright (C) 1992-2014 Free Software Foundation, Inc.
14f9c5c9 4
a9762ec7 5 This file is part of GDB.
14f9c5c9 6
a9762ec7
JB
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
14f9c5c9 11
a9762ec7
JB
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
14f9c5c9 16
a9762ec7
JB
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
14f9c5c9 19
96d887e8 20
4c4b4cd2 21#include "defs.h"
14f9c5c9 22#include <stdio.h>
0e9f083f 23#include <string.h>
14f9c5c9
AS
24#include <ctype.h>
25#include <stdarg.h>
26#include "demangle.h"
4c4b4cd2
PH
27#include "gdb_regex.h"
28#include "frame.h"
14f9c5c9
AS
29#include "symtab.h"
30#include "gdbtypes.h"
31#include "gdbcmd.h"
32#include "expression.h"
33#include "parser-defs.h"
34#include "language.h"
a53b64ea 35#include "varobj.h"
14f9c5c9
AS
36#include "c-lang.h"
37#include "inferior.h"
38#include "symfile.h"
39#include "objfiles.h"
40#include "breakpoint.h"
41#include "gdbcore.h"
4c4b4cd2
PH
42#include "hashtab.h"
43#include "gdb_obstack.h"
14f9c5c9 44#include "ada-lang.h"
4c4b4cd2 45#include "completer.h"
53ce3c39 46#include <sys/stat.h>
14f9c5c9 47#include "ui-out.h"
fe898f56 48#include "block.h"
04714b91 49#include "infcall.h"
de4f826b 50#include "dictionary.h"
60250e8b 51#include "exceptions.h"
f7f9143b
JB
52#include "annotate.h"
53#include "valprint.h"
9bbc9174 54#include "source.h"
0259addd 55#include "observer.h"
2ba95b9b 56#include "vec.h"
692465f1 57#include "stack.h"
fa864999 58#include "gdb_vecs.h"
79d43c61 59#include "typeprint.h"
14f9c5c9 60
ccefe4c4 61#include "psymtab.h"
40bc484c 62#include "value.h"
956a9fb9 63#include "mi/mi-common.h"
9ac4176b 64#include "arch-utils.h"
0fcd72ba 65#include "cli/cli-utils.h"
ccefe4c4 66
4c4b4cd2 67/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 68 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
69 Copied from valarith.c. */
70
71#ifndef TRUNCATION_TOWARDS_ZERO
72#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
73#endif
74
d2e4a39e 75static struct type *desc_base_type (struct type *);
14f9c5c9 76
d2e4a39e 77static struct type *desc_bounds_type (struct type *);
14f9c5c9 78
d2e4a39e 79static struct value *desc_bounds (struct value *);
14f9c5c9 80
d2e4a39e 81static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 82
d2e4a39e 83static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 84
556bdfd4 85static struct type *desc_data_target_type (struct type *);
14f9c5c9 86
d2e4a39e 87static struct value *desc_data (struct value *);
14f9c5c9 88
d2e4a39e 89static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 90
d2e4a39e 91static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 92
d2e4a39e 93static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 94
d2e4a39e 95static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 96
d2e4a39e 97static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 98
d2e4a39e 99static struct type *desc_index_type (struct type *, int);
14f9c5c9 100
d2e4a39e 101static int desc_arity (struct type *);
14f9c5c9 102
d2e4a39e 103static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 104
d2e4a39e 105static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 106
40658b94
PH
107static int full_match (const char *, const char *);
108
40bc484c 109static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 110
4c4b4cd2 111static void ada_add_block_symbols (struct obstack *,
f0c5f9b2 112 const struct block *, const char *,
2570f2b7 113 domain_enum, struct objfile *, int);
14f9c5c9 114
4c4b4cd2 115static int is_nonfunction (struct ada_symbol_info *, int);
14f9c5c9 116
76a01679 117static void add_defn_to_vec (struct obstack *, struct symbol *,
f0c5f9b2 118 const struct block *);
14f9c5c9 119
4c4b4cd2
PH
120static int num_defns_collected (struct obstack *);
121
122static struct ada_symbol_info *defns_collected (struct obstack *, int);
14f9c5c9 123
4c4b4cd2 124static struct value *resolve_subexp (struct expression **, int *, int,
76a01679 125 struct type *);
14f9c5c9 126
d2e4a39e 127static void replace_operator_with_call (struct expression **, int, int, int,
270140bd 128 struct symbol *, const struct block *);
14f9c5c9 129
d2e4a39e 130static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 131
4c4b4cd2
PH
132static char *ada_op_name (enum exp_opcode);
133
134static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 135
d2e4a39e 136static int numeric_type_p (struct type *);
14f9c5c9 137
d2e4a39e 138static int integer_type_p (struct type *);
14f9c5c9 139
d2e4a39e 140static int scalar_type_p (struct type *);
14f9c5c9 141
d2e4a39e 142static int discrete_type_p (struct type *);
14f9c5c9 143
aeb5907d
JB
144static enum ada_renaming_category parse_old_style_renaming (struct type *,
145 const char **,
146 int *,
147 const char **);
148
149static struct symbol *find_old_style_renaming_symbol (const char *,
270140bd 150 const struct block *);
aeb5907d 151
4c4b4cd2 152static struct type *ada_lookup_struct_elt_type (struct type *, char *,
76a01679 153 int, int, int *);
4c4b4cd2 154
d2e4a39e 155static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 156
b4ba55a1
JB
157static struct type *ada_find_parallel_type_with_name (struct type *,
158 const char *);
159
d2e4a39e 160static int is_dynamic_field (struct type *, int);
14f9c5c9 161
10a2c479 162static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 163 const gdb_byte *,
4c4b4cd2
PH
164 CORE_ADDR, struct value *);
165
166static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 167
28c85d6c 168static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 169
d2e4a39e 170static struct type *to_static_fixed_type (struct type *);
f192137b 171static struct type *static_unwrap_type (struct type *type);
14f9c5c9 172
d2e4a39e 173static struct value *unwrap_value (struct value *);
14f9c5c9 174
ad82864c 175static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 176
ad82864c 177static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 178
ad82864c
JB
179static long decode_packed_array_bitsize (struct type *);
180
181static struct value *decode_constrained_packed_array (struct value *);
182
183static int ada_is_packed_array_type (struct type *);
184
185static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 186
d2e4a39e 187static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 188 struct value **);
14f9c5c9 189
50810684 190static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
52ce6436 191
4c4b4cd2
PH
192static struct value *coerce_unspec_val_to_type (struct value *,
193 struct type *);
14f9c5c9 194
d2e4a39e 195static struct value *get_var_value (char *, char *);
14f9c5c9 196
d2e4a39e 197static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 198
d2e4a39e 199static int equiv_types (struct type *, struct type *);
14f9c5c9 200
d2e4a39e 201static int is_name_suffix (const char *);
14f9c5c9 202
73589123
PH
203static int advance_wild_match (const char **, const char *, int);
204
205static int wild_match (const char *, const char *);
14f9c5c9 206
d2e4a39e 207static struct value *ada_coerce_ref (struct value *);
14f9c5c9 208
4c4b4cd2
PH
209static LONGEST pos_atr (struct value *);
210
3cb382c9 211static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 212
d2e4a39e 213static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 214
4c4b4cd2
PH
215static struct symbol *standard_lookup (const char *, const struct block *,
216 domain_enum);
14f9c5c9 217
4c4b4cd2
PH
218static struct value *ada_search_struct_field (char *, struct value *, int,
219 struct type *);
220
221static struct value *ada_value_primitive_field (struct value *, int, int,
222 struct type *);
223
0d5cff50 224static int find_struct_field (const char *, struct type *, int,
52ce6436 225 struct type **, int *, int *, int *, int *);
4c4b4cd2
PH
226
227static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
228 struct value *);
229
4c4b4cd2
PH
230static int ada_resolve_function (struct ada_symbol_info *, int,
231 struct value **, int, const char *,
232 struct type *);
233
4c4b4cd2
PH
234static int ada_is_direct_array_type (struct type *);
235
72d5681a
PH
236static void ada_language_arch_info (struct gdbarch *,
237 struct language_arch_info *);
714e53ab
PH
238
239static void check_size (const struct type *);
52ce6436
PH
240
241static struct value *ada_index_struct_field (int, struct value *, int,
242 struct type *);
243
244static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
245 struct expression *,
246 int *, enum noside);
52ce6436
PH
247
248static void aggregate_assign_from_choices (struct value *, struct value *,
249 struct expression *,
250 int *, LONGEST *, int *,
251 int, LONGEST, LONGEST);
252
253static void aggregate_assign_positional (struct value *, struct value *,
254 struct expression *,
255 int *, LONGEST *, int *, int,
256 LONGEST, LONGEST);
257
258
259static void aggregate_assign_others (struct value *, struct value *,
260 struct expression *,
261 int *, LONGEST *, int, LONGEST, LONGEST);
262
263
264static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
265
266
267static struct value *ada_evaluate_subexp (struct type *, struct expression *,
268 int *, enum noside);
269
270static void ada_forward_operator_length (struct expression *, int, int *,
271 int *);
852dff6c
JB
272
273static struct type *ada_find_any_type (const char *name);
4c4b4cd2
PH
274\f
275
ee01b665
JB
276/* The result of a symbol lookup to be stored in our symbol cache. */
277
278struct cache_entry
279{
280 /* The name used to perform the lookup. */
281 const char *name;
282 /* The namespace used during the lookup. */
283 domain_enum namespace;
284 /* The symbol returned by the lookup, or NULL if no matching symbol
285 was found. */
286 struct symbol *sym;
287 /* The block where the symbol was found, or NULL if no matching
288 symbol was found. */
289 const struct block *block;
290 /* A pointer to the next entry with the same hash. */
291 struct cache_entry *next;
292};
293
294/* The Ada symbol cache, used to store the result of Ada-mode symbol
295 lookups in the course of executing the user's commands.
296
297 The cache is implemented using a simple, fixed-sized hash.
298 The size is fixed on the grounds that there are not likely to be
299 all that many symbols looked up during any given session, regardless
300 of the size of the symbol table. If we decide to go to a resizable
301 table, let's just use the stuff from libiberty instead. */
302
303#define HASH_SIZE 1009
304
305struct ada_symbol_cache
306{
307 /* An obstack used to store the entries in our cache. */
308 struct obstack cache_space;
309
310 /* The root of the hash table used to implement our symbol cache. */
311 struct cache_entry *root[HASH_SIZE];
312};
313
314static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
76a01679 315
4c4b4cd2 316/* Maximum-sized dynamic type. */
14f9c5c9
AS
317static unsigned int varsize_limit;
318
4c4b4cd2
PH
319/* FIXME: brobecker/2003-09-17: No longer a const because it is
320 returned by a function that does not return a const char *. */
321static char *ada_completer_word_break_characters =
322#ifdef VMS
323 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
324#else
14f9c5c9 325 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 326#endif
14f9c5c9 327
4c4b4cd2 328/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 329static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 330 = "__gnat_ada_main_program_name";
14f9c5c9 331
4c4b4cd2
PH
332/* Limit on the number of warnings to raise per expression evaluation. */
333static int warning_limit = 2;
334
335/* Number of warning messages issued; reset to 0 by cleanups after
336 expression evaluation. */
337static int warnings_issued = 0;
338
339static const char *known_runtime_file_name_patterns[] = {
340 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
341};
342
343static const char *known_auxiliary_function_name_patterns[] = {
344 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
345};
346
347/* Space for allocating results of ada_lookup_symbol_list. */
348static struct obstack symbol_list_obstack;
349
c6044dd1
JB
350/* Maintenance-related settings for this module. */
351
352static struct cmd_list_element *maint_set_ada_cmdlist;
353static struct cmd_list_element *maint_show_ada_cmdlist;
354
355/* Implement the "maintenance set ada" (prefix) command. */
356
357static void
358maint_set_ada_cmd (char *args, int from_tty)
359{
360 help_list (maint_set_ada_cmdlist, "maintenance set ada ", -1, gdb_stdout);
361}
362
363/* Implement the "maintenance show ada" (prefix) command. */
364
365static void
366maint_show_ada_cmd (char *args, int from_tty)
367{
368 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
369}
370
371/* The "maintenance ada set/show ignore-descriptive-type" value. */
372
373static int ada_ignore_descriptive_types_p = 0;
374
e802dbe0
JB
375 /* Inferior-specific data. */
376
377/* Per-inferior data for this module. */
378
379struct ada_inferior_data
380{
381 /* The ada__tags__type_specific_data type, which is used when decoding
382 tagged types. With older versions of GNAT, this type was directly
383 accessible through a component ("tsd") in the object tag. But this
384 is no longer the case, so we cache it for each inferior. */
385 struct type *tsd_type;
3eecfa55
JB
386
387 /* The exception_support_info data. This data is used to determine
388 how to implement support for Ada exception catchpoints in a given
389 inferior. */
390 const struct exception_support_info *exception_info;
e802dbe0
JB
391};
392
393/* Our key to this module's inferior data. */
394static const struct inferior_data *ada_inferior_data;
395
396/* A cleanup routine for our inferior data. */
397static void
398ada_inferior_data_cleanup (struct inferior *inf, void *arg)
399{
400 struct ada_inferior_data *data;
401
402 data = inferior_data (inf, ada_inferior_data);
403 if (data != NULL)
404 xfree (data);
405}
406
407/* Return our inferior data for the given inferior (INF).
408
409 This function always returns a valid pointer to an allocated
410 ada_inferior_data structure. If INF's inferior data has not
411 been previously set, this functions creates a new one with all
412 fields set to zero, sets INF's inferior to it, and then returns
413 a pointer to that newly allocated ada_inferior_data. */
414
415static struct ada_inferior_data *
416get_ada_inferior_data (struct inferior *inf)
417{
418 struct ada_inferior_data *data;
419
420 data = inferior_data (inf, ada_inferior_data);
421 if (data == NULL)
422 {
41bf6aca 423 data = XCNEW (struct ada_inferior_data);
e802dbe0
JB
424 set_inferior_data (inf, ada_inferior_data, data);
425 }
426
427 return data;
428}
429
430/* Perform all necessary cleanups regarding our module's inferior data
431 that is required after the inferior INF just exited. */
432
433static void
434ada_inferior_exit (struct inferior *inf)
435{
436 ada_inferior_data_cleanup (inf, NULL);
437 set_inferior_data (inf, ada_inferior_data, NULL);
438}
439
ee01b665
JB
440
441 /* program-space-specific data. */
442
443/* This module's per-program-space data. */
444struct ada_pspace_data
445{
446 /* The Ada symbol cache. */
447 struct ada_symbol_cache *sym_cache;
448};
449
450/* Key to our per-program-space data. */
451static const struct program_space_data *ada_pspace_data_handle;
452
453/* Return this module's data for the given program space (PSPACE).
454 If not is found, add a zero'ed one now.
455
456 This function always returns a valid object. */
457
458static struct ada_pspace_data *
459get_ada_pspace_data (struct program_space *pspace)
460{
461 struct ada_pspace_data *data;
462
463 data = program_space_data (pspace, ada_pspace_data_handle);
464 if (data == NULL)
465 {
466 data = XCNEW (struct ada_pspace_data);
467 set_program_space_data (pspace, ada_pspace_data_handle, data);
468 }
469
470 return data;
471}
472
473/* The cleanup callback for this module's per-program-space data. */
474
475static void
476ada_pspace_data_cleanup (struct program_space *pspace, void *data)
477{
478 struct ada_pspace_data *pspace_data = data;
479
480 if (pspace_data->sym_cache != NULL)
481 ada_free_symbol_cache (pspace_data->sym_cache);
482 xfree (pspace_data);
483}
484
4c4b4cd2
PH
485 /* Utilities */
486
720d1a40 487/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
eed9788b 488 all typedef layers have been peeled. Otherwise, return TYPE.
720d1a40
JB
489
490 Normally, we really expect a typedef type to only have 1 typedef layer.
491 In other words, we really expect the target type of a typedef type to be
492 a non-typedef type. This is particularly true for Ada units, because
493 the language does not have a typedef vs not-typedef distinction.
494 In that respect, the Ada compiler has been trying to eliminate as many
495 typedef definitions in the debugging information, since they generally
496 do not bring any extra information (we still use typedef under certain
497 circumstances related mostly to the GNAT encoding).
498
499 Unfortunately, we have seen situations where the debugging information
500 generated by the compiler leads to such multiple typedef layers. For
501 instance, consider the following example with stabs:
502
503 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
504 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
505
506 This is an error in the debugging information which causes type
507 pck__float_array___XUP to be defined twice, and the second time,
508 it is defined as a typedef of a typedef.
509
510 This is on the fringe of legality as far as debugging information is
511 concerned, and certainly unexpected. But it is easy to handle these
512 situations correctly, so we can afford to be lenient in this case. */
513
514static struct type *
515ada_typedef_target_type (struct type *type)
516{
517 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
518 type = TYPE_TARGET_TYPE (type);
519 return type;
520}
521
41d27058
JB
522/* Given DECODED_NAME a string holding a symbol name in its
523 decoded form (ie using the Ada dotted notation), returns
524 its unqualified name. */
525
526static const char *
527ada_unqualified_name (const char *decoded_name)
528{
529 const char *result = strrchr (decoded_name, '.');
530
531 if (result != NULL)
532 result++; /* Skip the dot... */
533 else
534 result = decoded_name;
535
536 return result;
537}
538
539/* Return a string starting with '<', followed by STR, and '>'.
540 The result is good until the next call. */
541
542static char *
543add_angle_brackets (const char *str)
544{
545 static char *result = NULL;
546
547 xfree (result);
88c15c34 548 result = xstrprintf ("<%s>", str);
41d27058
JB
549 return result;
550}
96d887e8 551
4c4b4cd2
PH
552static char *
553ada_get_gdb_completer_word_break_characters (void)
554{
555 return ada_completer_word_break_characters;
556}
557
e79af960
JB
558/* Print an array element index using the Ada syntax. */
559
560static void
561ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 562 const struct value_print_options *options)
e79af960 563{
79a45b7d 564 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
565 fprintf_filtered (stream, " => ");
566}
567
f27cf670 568/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 569 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 570 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 571
f27cf670
AS
572void *
573grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 574{
d2e4a39e
AS
575 if (*size < min_size)
576 {
577 *size *= 2;
578 if (*size < min_size)
4c4b4cd2 579 *size = min_size;
f27cf670 580 vect = xrealloc (vect, *size * element_size);
d2e4a39e 581 }
f27cf670 582 return vect;
14f9c5c9
AS
583}
584
585/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 586 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
587
588static int
ebf56fd3 589field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
590{
591 int len = strlen (target);
5b4ee69b 592
d2e4a39e 593 return
4c4b4cd2
PH
594 (strncmp (field_name, target, len) == 0
595 && (field_name[len] == '\0'
596 || (strncmp (field_name + len, "___", 3) == 0
76a01679
JB
597 && strcmp (field_name + strlen (field_name) - 6,
598 "___XVN") != 0)));
14f9c5c9
AS
599}
600
601
872c8b51
JB
602/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
603 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
604 and return its index. This function also handles fields whose name
605 have ___ suffixes because the compiler sometimes alters their name
606 by adding such a suffix to represent fields with certain constraints.
607 If the field could not be found, return a negative number if
608 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
609
610int
611ada_get_field_index (const struct type *type, const char *field_name,
612 int maybe_missing)
613{
614 int fieldno;
872c8b51
JB
615 struct type *struct_type = check_typedef ((struct type *) type);
616
617 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
618 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
619 return fieldno;
620
621 if (!maybe_missing)
323e0a4a 622 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 623 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
624
625 return -1;
626}
627
628/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
629
630int
d2e4a39e 631ada_name_prefix_len (const char *name)
14f9c5c9
AS
632{
633 if (name == NULL)
634 return 0;
d2e4a39e 635 else
14f9c5c9 636 {
d2e4a39e 637 const char *p = strstr (name, "___");
5b4ee69b 638
14f9c5c9 639 if (p == NULL)
4c4b4cd2 640 return strlen (name);
14f9c5c9 641 else
4c4b4cd2 642 return p - name;
14f9c5c9
AS
643 }
644}
645
4c4b4cd2
PH
646/* Return non-zero if SUFFIX is a suffix of STR.
647 Return zero if STR is null. */
648
14f9c5c9 649static int
d2e4a39e 650is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
651{
652 int len1, len2;
5b4ee69b 653
14f9c5c9
AS
654 if (str == NULL)
655 return 0;
656 len1 = strlen (str);
657 len2 = strlen (suffix);
4c4b4cd2 658 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
659}
660
4c4b4cd2
PH
661/* The contents of value VAL, treated as a value of type TYPE. The
662 result is an lval in memory if VAL is. */
14f9c5c9 663
d2e4a39e 664static struct value *
4c4b4cd2 665coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 666{
61ee279c 667 type = ada_check_typedef (type);
df407dfe 668 if (value_type (val) == type)
4c4b4cd2 669 return val;
d2e4a39e 670 else
14f9c5c9 671 {
4c4b4cd2
PH
672 struct value *result;
673
674 /* Make sure that the object size is not unreasonable before
675 trying to allocate some memory for it. */
714e53ab 676 check_size (type);
4c4b4cd2 677
41e8491f
JK
678 if (value_lazy (val)
679 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
680 result = allocate_value_lazy (type);
681 else
682 {
683 result = allocate_value (type);
684 memcpy (value_contents_raw (result), value_contents (val),
685 TYPE_LENGTH (type));
686 }
74bcbdf3 687 set_value_component_location (result, val);
9bbda503
AC
688 set_value_bitsize (result, value_bitsize (val));
689 set_value_bitpos (result, value_bitpos (val));
42ae5230 690 set_value_address (result, value_address (val));
eca07816 691 set_value_optimized_out (result, value_optimized_out_const (val));
14f9c5c9
AS
692 return result;
693 }
694}
695
fc1a4b47
AC
696static const gdb_byte *
697cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
698{
699 if (valaddr == NULL)
700 return NULL;
701 else
702 return valaddr + offset;
703}
704
705static CORE_ADDR
ebf56fd3 706cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
707{
708 if (address == 0)
709 return 0;
d2e4a39e 710 else
14f9c5c9
AS
711 return address + offset;
712}
713
4c4b4cd2
PH
714/* Issue a warning (as for the definition of warning in utils.c, but
715 with exactly one argument rather than ...), unless the limit on the
716 number of warnings has passed during the evaluation of the current
717 expression. */
a2249542 718
77109804
AC
719/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
720 provided by "complaint". */
a0b31db1 721static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 722
14f9c5c9 723static void
a2249542 724lim_warning (const char *format, ...)
14f9c5c9 725{
a2249542 726 va_list args;
a2249542 727
5b4ee69b 728 va_start (args, format);
4c4b4cd2
PH
729 warnings_issued += 1;
730 if (warnings_issued <= warning_limit)
a2249542
MK
731 vwarning (format, args);
732
733 va_end (args);
4c4b4cd2
PH
734}
735
714e53ab
PH
736/* Issue an error if the size of an object of type T is unreasonable,
737 i.e. if it would be a bad idea to allocate a value of this type in
738 GDB. */
739
740static void
741check_size (const struct type *type)
742{
743 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 744 error (_("object size is larger than varsize-limit"));
714e53ab
PH
745}
746
0963b4bd 747/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 748static LONGEST
c3e5cd34 749max_of_size (int size)
4c4b4cd2 750{
76a01679 751 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 752
76a01679 753 return top_bit | (top_bit - 1);
4c4b4cd2
PH
754}
755
0963b4bd 756/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 757static LONGEST
c3e5cd34 758min_of_size (int size)
4c4b4cd2 759{
c3e5cd34 760 return -max_of_size (size) - 1;
4c4b4cd2
PH
761}
762
0963b4bd 763/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 764static ULONGEST
c3e5cd34 765umax_of_size (int size)
4c4b4cd2 766{
76a01679 767 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 768
76a01679 769 return top_bit | (top_bit - 1);
4c4b4cd2
PH
770}
771
0963b4bd 772/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
773static LONGEST
774max_of_type (struct type *t)
4c4b4cd2 775{
c3e5cd34
PH
776 if (TYPE_UNSIGNED (t))
777 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
778 else
779 return max_of_size (TYPE_LENGTH (t));
780}
781
0963b4bd 782/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
783static LONGEST
784min_of_type (struct type *t)
785{
786 if (TYPE_UNSIGNED (t))
787 return 0;
788 else
789 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
790}
791
792/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
793LONGEST
794ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 795{
76a01679 796 switch (TYPE_CODE (type))
4c4b4cd2
PH
797 {
798 case TYPE_CODE_RANGE:
690cc4eb 799 return TYPE_HIGH_BOUND (type);
4c4b4cd2 800 case TYPE_CODE_ENUM:
14e75d8e 801 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
802 case TYPE_CODE_BOOL:
803 return 1;
804 case TYPE_CODE_CHAR:
76a01679 805 case TYPE_CODE_INT:
690cc4eb 806 return max_of_type (type);
4c4b4cd2 807 default:
43bbcdc2 808 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
809 }
810}
811
14e75d8e 812/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
813LONGEST
814ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 815{
76a01679 816 switch (TYPE_CODE (type))
4c4b4cd2
PH
817 {
818 case TYPE_CODE_RANGE:
690cc4eb 819 return TYPE_LOW_BOUND (type);
4c4b4cd2 820 case TYPE_CODE_ENUM:
14e75d8e 821 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
822 case TYPE_CODE_BOOL:
823 return 0;
824 case TYPE_CODE_CHAR:
76a01679 825 case TYPE_CODE_INT:
690cc4eb 826 return min_of_type (type);
4c4b4cd2 827 default:
43bbcdc2 828 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
829 }
830}
831
832/* The identity on non-range types. For range types, the underlying
76a01679 833 non-range scalar type. */
4c4b4cd2
PH
834
835static struct type *
18af8284 836get_base_type (struct type *type)
4c4b4cd2
PH
837{
838 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
839 {
76a01679
JB
840 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
841 return type;
4c4b4cd2
PH
842 type = TYPE_TARGET_TYPE (type);
843 }
844 return type;
14f9c5c9 845}
41246937
JB
846
847/* Return a decoded version of the given VALUE. This means returning
848 a value whose type is obtained by applying all the GNAT-specific
849 encondings, making the resulting type a static but standard description
850 of the initial type. */
851
852struct value *
853ada_get_decoded_value (struct value *value)
854{
855 struct type *type = ada_check_typedef (value_type (value));
856
857 if (ada_is_array_descriptor_type (type)
858 || (ada_is_constrained_packed_array_type (type)
859 && TYPE_CODE (type) != TYPE_CODE_PTR))
860 {
861 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
862 value = ada_coerce_to_simple_array_ptr (value);
863 else
864 value = ada_coerce_to_simple_array (value);
865 }
866 else
867 value = ada_to_fixed_value (value);
868
869 return value;
870}
871
872/* Same as ada_get_decoded_value, but with the given TYPE.
873 Because there is no associated actual value for this type,
874 the resulting type might be a best-effort approximation in
875 the case of dynamic types. */
876
877struct type *
878ada_get_decoded_type (struct type *type)
879{
880 type = to_static_fixed_type (type);
881 if (ada_is_constrained_packed_array_type (type))
882 type = ada_coerce_to_simple_array_type (type);
883 return type;
884}
885
4c4b4cd2 886\f
76a01679 887
4c4b4cd2 888 /* Language Selection */
14f9c5c9
AS
889
890/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 891 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 892
14f9c5c9 893enum language
ccefe4c4 894ada_update_initial_language (enum language lang)
14f9c5c9 895{
d2e4a39e 896 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
3b7344d5 897 (struct objfile *) NULL).minsym != NULL)
4c4b4cd2 898 return language_ada;
14f9c5c9
AS
899
900 return lang;
901}
96d887e8
PH
902
903/* If the main procedure is written in Ada, then return its name.
904 The result is good until the next call. Return NULL if the main
905 procedure doesn't appear to be in Ada. */
906
907char *
908ada_main_name (void)
909{
3b7344d5 910 struct bound_minimal_symbol msym;
f9bc20b9 911 static char *main_program_name = NULL;
6c038f32 912
96d887e8
PH
913 /* For Ada, the name of the main procedure is stored in a specific
914 string constant, generated by the binder. Look for that symbol,
915 extract its address, and then read that string. If we didn't find
916 that string, then most probably the main procedure is not written
917 in Ada. */
918 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
919
3b7344d5 920 if (msym.minsym != NULL)
96d887e8 921 {
f9bc20b9
JB
922 CORE_ADDR main_program_name_addr;
923 int err_code;
924
3b7344d5 925 main_program_name_addr = MSYMBOL_VALUE_ADDRESS (msym.minsym);
96d887e8 926 if (main_program_name_addr == 0)
323e0a4a 927 error (_("Invalid address for Ada main program name."));
96d887e8 928
f9bc20b9
JB
929 xfree (main_program_name);
930 target_read_string (main_program_name_addr, &main_program_name,
931 1024, &err_code);
932
933 if (err_code != 0)
934 return NULL;
96d887e8
PH
935 return main_program_name;
936 }
937
938 /* The main procedure doesn't seem to be in Ada. */
939 return NULL;
940}
14f9c5c9 941\f
4c4b4cd2 942 /* Symbols */
d2e4a39e 943
4c4b4cd2
PH
944/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
945 of NULLs. */
14f9c5c9 946
d2e4a39e
AS
947const struct ada_opname_map ada_opname_table[] = {
948 {"Oadd", "\"+\"", BINOP_ADD},
949 {"Osubtract", "\"-\"", BINOP_SUB},
950 {"Omultiply", "\"*\"", BINOP_MUL},
951 {"Odivide", "\"/\"", BINOP_DIV},
952 {"Omod", "\"mod\"", BINOP_MOD},
953 {"Orem", "\"rem\"", BINOP_REM},
954 {"Oexpon", "\"**\"", BINOP_EXP},
955 {"Olt", "\"<\"", BINOP_LESS},
956 {"Ole", "\"<=\"", BINOP_LEQ},
957 {"Ogt", "\">\"", BINOP_GTR},
958 {"Oge", "\">=\"", BINOP_GEQ},
959 {"Oeq", "\"=\"", BINOP_EQUAL},
960 {"One", "\"/=\"", BINOP_NOTEQUAL},
961 {"Oand", "\"and\"", BINOP_BITWISE_AND},
962 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
963 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
964 {"Oconcat", "\"&\"", BINOP_CONCAT},
965 {"Oabs", "\"abs\"", UNOP_ABS},
966 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
967 {"Oadd", "\"+\"", UNOP_PLUS},
968 {"Osubtract", "\"-\"", UNOP_NEG},
969 {NULL, NULL}
14f9c5c9
AS
970};
971
4c4b4cd2
PH
972/* The "encoded" form of DECODED, according to GNAT conventions.
973 The result is valid until the next call to ada_encode. */
974
14f9c5c9 975char *
4c4b4cd2 976ada_encode (const char *decoded)
14f9c5c9 977{
4c4b4cd2
PH
978 static char *encoding_buffer = NULL;
979 static size_t encoding_buffer_size = 0;
d2e4a39e 980 const char *p;
14f9c5c9 981 int k;
d2e4a39e 982
4c4b4cd2 983 if (decoded == NULL)
14f9c5c9
AS
984 return NULL;
985
4c4b4cd2
PH
986 GROW_VECT (encoding_buffer, encoding_buffer_size,
987 2 * strlen (decoded) + 10);
14f9c5c9
AS
988
989 k = 0;
4c4b4cd2 990 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 991 {
cdc7bb92 992 if (*p == '.')
4c4b4cd2
PH
993 {
994 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
995 k += 2;
996 }
14f9c5c9 997 else if (*p == '"')
4c4b4cd2
PH
998 {
999 const struct ada_opname_map *mapping;
1000
1001 for (mapping = ada_opname_table;
1265e4aa
JB
1002 mapping->encoded != NULL
1003 && strncmp (mapping->decoded, p,
1004 strlen (mapping->decoded)) != 0; mapping += 1)
4c4b4cd2
PH
1005 ;
1006 if (mapping->encoded == NULL)
323e0a4a 1007 error (_("invalid Ada operator name: %s"), p);
4c4b4cd2
PH
1008 strcpy (encoding_buffer + k, mapping->encoded);
1009 k += strlen (mapping->encoded);
1010 break;
1011 }
d2e4a39e 1012 else
4c4b4cd2
PH
1013 {
1014 encoding_buffer[k] = *p;
1015 k += 1;
1016 }
14f9c5c9
AS
1017 }
1018
4c4b4cd2
PH
1019 encoding_buffer[k] = '\0';
1020 return encoding_buffer;
14f9c5c9
AS
1021}
1022
1023/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
1024 quotes, unfolded, but with the quotes stripped away. Result good
1025 to next call. */
1026
d2e4a39e
AS
1027char *
1028ada_fold_name (const char *name)
14f9c5c9 1029{
d2e4a39e 1030 static char *fold_buffer = NULL;
14f9c5c9
AS
1031 static size_t fold_buffer_size = 0;
1032
1033 int len = strlen (name);
d2e4a39e 1034 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
1035
1036 if (name[0] == '\'')
1037 {
d2e4a39e
AS
1038 strncpy (fold_buffer, name + 1, len - 2);
1039 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
1040 }
1041 else
1042 {
1043 int i;
5b4ee69b 1044
14f9c5c9 1045 for (i = 0; i <= len; i += 1)
4c4b4cd2 1046 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
1047 }
1048
1049 return fold_buffer;
1050}
1051
529cad9c
PH
1052/* Return nonzero if C is either a digit or a lowercase alphabet character. */
1053
1054static int
1055is_lower_alphanum (const char c)
1056{
1057 return (isdigit (c) || (isalpha (c) && islower (c)));
1058}
1059
c90092fe
JB
1060/* ENCODED is the linkage name of a symbol and LEN contains its length.
1061 This function saves in LEN the length of that same symbol name but
1062 without either of these suffixes:
29480c32
JB
1063 . .{DIGIT}+
1064 . ${DIGIT}+
1065 . ___{DIGIT}+
1066 . __{DIGIT}+.
c90092fe 1067
29480c32
JB
1068 These are suffixes introduced by the compiler for entities such as
1069 nested subprogram for instance, in order to avoid name clashes.
1070 They do not serve any purpose for the debugger. */
1071
1072static void
1073ada_remove_trailing_digits (const char *encoded, int *len)
1074{
1075 if (*len > 1 && isdigit (encoded[*len - 1]))
1076 {
1077 int i = *len - 2;
5b4ee69b 1078
29480c32
JB
1079 while (i > 0 && isdigit (encoded[i]))
1080 i--;
1081 if (i >= 0 && encoded[i] == '.')
1082 *len = i;
1083 else if (i >= 0 && encoded[i] == '$')
1084 *len = i;
1085 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
1086 *len = i - 2;
1087 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
1088 *len = i - 1;
1089 }
1090}
1091
1092/* Remove the suffix introduced by the compiler for protected object
1093 subprograms. */
1094
1095static void
1096ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1097{
1098 /* Remove trailing N. */
1099
1100 /* Protected entry subprograms are broken into two
1101 separate subprograms: The first one is unprotected, and has
1102 a 'N' suffix; the second is the protected version, and has
0963b4bd 1103 the 'P' suffix. The second calls the first one after handling
29480c32
JB
1104 the protection. Since the P subprograms are internally generated,
1105 we leave these names undecoded, giving the user a clue that this
1106 entity is internal. */
1107
1108 if (*len > 1
1109 && encoded[*len - 1] == 'N'
1110 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1111 *len = *len - 1;
1112}
1113
69fadcdf
JB
1114/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1115
1116static void
1117ada_remove_Xbn_suffix (const char *encoded, int *len)
1118{
1119 int i = *len - 1;
1120
1121 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1122 i--;
1123
1124 if (encoded[i] != 'X')
1125 return;
1126
1127 if (i == 0)
1128 return;
1129
1130 if (isalnum (encoded[i-1]))
1131 *len = i;
1132}
1133
29480c32
JB
1134/* If ENCODED follows the GNAT entity encoding conventions, then return
1135 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1136 replaced by ENCODED.
14f9c5c9 1137
4c4b4cd2 1138 The resulting string is valid until the next call of ada_decode.
29480c32 1139 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1140 is returned. */
1141
1142const char *
1143ada_decode (const char *encoded)
14f9c5c9
AS
1144{
1145 int i, j;
1146 int len0;
d2e4a39e 1147 const char *p;
4c4b4cd2 1148 char *decoded;
14f9c5c9 1149 int at_start_name;
4c4b4cd2
PH
1150 static char *decoding_buffer = NULL;
1151 static size_t decoding_buffer_size = 0;
d2e4a39e 1152
29480c32
JB
1153 /* The name of the Ada main procedure starts with "_ada_".
1154 This prefix is not part of the decoded name, so skip this part
1155 if we see this prefix. */
4c4b4cd2
PH
1156 if (strncmp (encoded, "_ada_", 5) == 0)
1157 encoded += 5;
14f9c5c9 1158
29480c32
JB
1159 /* If the name starts with '_', then it is not a properly encoded
1160 name, so do not attempt to decode it. Similarly, if the name
1161 starts with '<', the name should not be decoded. */
4c4b4cd2 1162 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1163 goto Suppress;
1164
4c4b4cd2 1165 len0 = strlen (encoded);
4c4b4cd2 1166
29480c32
JB
1167 ada_remove_trailing_digits (encoded, &len0);
1168 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1169
4c4b4cd2
PH
1170 /* Remove the ___X.* suffix if present. Do not forget to verify that
1171 the suffix is located before the current "end" of ENCODED. We want
1172 to avoid re-matching parts of ENCODED that have previously been
1173 marked as discarded (by decrementing LEN0). */
1174 p = strstr (encoded, "___");
1175 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1176 {
1177 if (p[3] == 'X')
4c4b4cd2 1178 len0 = p - encoded;
14f9c5c9 1179 else
4c4b4cd2 1180 goto Suppress;
14f9c5c9 1181 }
4c4b4cd2 1182
29480c32
JB
1183 /* Remove any trailing TKB suffix. It tells us that this symbol
1184 is for the body of a task, but that information does not actually
1185 appear in the decoded name. */
1186
4c4b4cd2 1187 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
14f9c5c9 1188 len0 -= 3;
76a01679 1189
a10967fa
JB
1190 /* Remove any trailing TB suffix. The TB suffix is slightly different
1191 from the TKB suffix because it is used for non-anonymous task
1192 bodies. */
1193
1194 if (len0 > 2 && strncmp (encoded + len0 - 2, "TB", 2) == 0)
1195 len0 -= 2;
1196
29480c32
JB
1197 /* Remove trailing "B" suffixes. */
1198 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1199
4c4b4cd2 1200 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
14f9c5c9
AS
1201 len0 -= 1;
1202
4c4b4cd2 1203 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1204
4c4b4cd2
PH
1205 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1206 decoded = decoding_buffer;
14f9c5c9 1207
29480c32
JB
1208 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1209
4c4b4cd2 1210 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1211 {
4c4b4cd2
PH
1212 i = len0 - 2;
1213 while ((i >= 0 && isdigit (encoded[i]))
1214 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1215 i -= 1;
1216 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1217 len0 = i - 1;
1218 else if (encoded[i] == '$')
1219 len0 = i;
d2e4a39e 1220 }
14f9c5c9 1221
29480c32
JB
1222 /* The first few characters that are not alphabetic are not part
1223 of any encoding we use, so we can copy them over verbatim. */
1224
4c4b4cd2
PH
1225 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1226 decoded[j] = encoded[i];
14f9c5c9
AS
1227
1228 at_start_name = 1;
1229 while (i < len0)
1230 {
29480c32 1231 /* Is this a symbol function? */
4c4b4cd2
PH
1232 if (at_start_name && encoded[i] == 'O')
1233 {
1234 int k;
5b4ee69b 1235
4c4b4cd2
PH
1236 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1237 {
1238 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1239 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1240 op_len - 1) == 0)
1241 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1242 {
1243 strcpy (decoded + j, ada_opname_table[k].decoded);
1244 at_start_name = 0;
1245 i += op_len;
1246 j += strlen (ada_opname_table[k].decoded);
1247 break;
1248 }
1249 }
1250 if (ada_opname_table[k].encoded != NULL)
1251 continue;
1252 }
14f9c5c9
AS
1253 at_start_name = 0;
1254
529cad9c
PH
1255 /* Replace "TK__" with "__", which will eventually be translated
1256 into "." (just below). */
1257
4c4b4cd2
PH
1258 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
1259 i += 2;
529cad9c 1260
29480c32
JB
1261 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1262 be translated into "." (just below). These are internal names
1263 generated for anonymous blocks inside which our symbol is nested. */
1264
1265 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1266 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1267 && isdigit (encoded [i+4]))
1268 {
1269 int k = i + 5;
1270
1271 while (k < len0 && isdigit (encoded[k]))
1272 k++; /* Skip any extra digit. */
1273
1274 /* Double-check that the "__B_{DIGITS}+" sequence we found
1275 is indeed followed by "__". */
1276 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1277 i = k;
1278 }
1279
529cad9c
PH
1280 /* Remove _E{DIGITS}+[sb] */
1281
1282 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1283 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1284 one implements the actual entry code, and has a suffix following
1285 the convention above; the second one implements the barrier and
1286 uses the same convention as above, except that the 'E' is replaced
1287 by a 'B'.
1288
1289 Just as above, we do not decode the name of barrier functions
1290 to give the user a clue that the code he is debugging has been
1291 internally generated. */
1292
1293 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1294 && isdigit (encoded[i+2]))
1295 {
1296 int k = i + 3;
1297
1298 while (k < len0 && isdigit (encoded[k]))
1299 k++;
1300
1301 if (k < len0
1302 && (encoded[k] == 'b' || encoded[k] == 's'))
1303 {
1304 k++;
1305 /* Just as an extra precaution, make sure that if this
1306 suffix is followed by anything else, it is a '_'.
1307 Otherwise, we matched this sequence by accident. */
1308 if (k == len0
1309 || (k < len0 && encoded[k] == '_'))
1310 i = k;
1311 }
1312 }
1313
1314 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1315 the GNAT front-end in protected object subprograms. */
1316
1317 if (i < len0 + 3
1318 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1319 {
1320 /* Backtrack a bit up until we reach either the begining of
1321 the encoded name, or "__". Make sure that we only find
1322 digits or lowercase characters. */
1323 const char *ptr = encoded + i - 1;
1324
1325 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1326 ptr--;
1327 if (ptr < encoded
1328 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1329 i++;
1330 }
1331
4c4b4cd2
PH
1332 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1333 {
29480c32
JB
1334 /* This is a X[bn]* sequence not separated from the previous
1335 part of the name with a non-alpha-numeric character (in other
1336 words, immediately following an alpha-numeric character), then
1337 verify that it is placed at the end of the encoded name. If
1338 not, then the encoding is not valid and we should abort the
1339 decoding. Otherwise, just skip it, it is used in body-nested
1340 package names. */
4c4b4cd2
PH
1341 do
1342 i += 1;
1343 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1344 if (i < len0)
1345 goto Suppress;
1346 }
cdc7bb92 1347 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1348 {
29480c32 1349 /* Replace '__' by '.'. */
4c4b4cd2
PH
1350 decoded[j] = '.';
1351 at_start_name = 1;
1352 i += 2;
1353 j += 1;
1354 }
14f9c5c9 1355 else
4c4b4cd2 1356 {
29480c32
JB
1357 /* It's a character part of the decoded name, so just copy it
1358 over. */
4c4b4cd2
PH
1359 decoded[j] = encoded[i];
1360 i += 1;
1361 j += 1;
1362 }
14f9c5c9 1363 }
4c4b4cd2 1364 decoded[j] = '\000';
14f9c5c9 1365
29480c32
JB
1366 /* Decoded names should never contain any uppercase character.
1367 Double-check this, and abort the decoding if we find one. */
1368
4c4b4cd2
PH
1369 for (i = 0; decoded[i] != '\0'; i += 1)
1370 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1371 goto Suppress;
1372
4c4b4cd2
PH
1373 if (strcmp (decoded, encoded) == 0)
1374 return encoded;
1375 else
1376 return decoded;
14f9c5c9
AS
1377
1378Suppress:
4c4b4cd2
PH
1379 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1380 decoded = decoding_buffer;
1381 if (encoded[0] == '<')
1382 strcpy (decoded, encoded);
14f9c5c9 1383 else
88c15c34 1384 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1385 return decoded;
1386
1387}
1388
1389/* Table for keeping permanent unique copies of decoded names. Once
1390 allocated, names in this table are never released. While this is a
1391 storage leak, it should not be significant unless there are massive
1392 changes in the set of decoded names in successive versions of a
1393 symbol table loaded during a single session. */
1394static struct htab *decoded_names_store;
1395
1396/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1397 in the language-specific part of GSYMBOL, if it has not been
1398 previously computed. Tries to save the decoded name in the same
1399 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1400 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1401 GSYMBOL).
4c4b4cd2
PH
1402 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1403 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1404 when a decoded name is cached in it. */
4c4b4cd2 1405
45e6c716 1406const char *
f85f34ed 1407ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1408{
f85f34ed
TT
1409 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1410 const char **resultp =
1411 &gsymbol->language_specific.mangled_lang.demangled_name;
5b4ee69b 1412
f85f34ed 1413 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1414 {
1415 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1416 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1417
f85f34ed 1418 gsymbol->ada_mangled = 1;
5b4ee69b 1419
f85f34ed
TT
1420 if (obstack != NULL)
1421 *resultp = obstack_copy0 (obstack, decoded, strlen (decoded));
1422 else
76a01679 1423 {
f85f34ed
TT
1424 /* Sometimes, we can't find a corresponding objfile, in
1425 which case, we put the result on the heap. Since we only
1426 decode when needed, we hope this usually does not cause a
1427 significant memory leak (FIXME). */
1428
76a01679
JB
1429 char **slot = (char **) htab_find_slot (decoded_names_store,
1430 decoded, INSERT);
5b4ee69b 1431
76a01679
JB
1432 if (*slot == NULL)
1433 *slot = xstrdup (decoded);
1434 *resultp = *slot;
1435 }
4c4b4cd2 1436 }
14f9c5c9 1437
4c4b4cd2
PH
1438 return *resultp;
1439}
76a01679 1440
2c0b251b 1441static char *
76a01679 1442ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1443{
1444 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1445}
1446
1447/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
4c4b4cd2
PH
1448 suffixes that encode debugging information or leading _ada_ on
1449 SYM_NAME (see is_name_suffix commentary for the debugging
1450 information that is ignored). If WILD, then NAME need only match a
1451 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1452 either argument is NULL. */
14f9c5c9 1453
2c0b251b 1454static int
40658b94 1455match_name (const char *sym_name, const char *name, int wild)
14f9c5c9
AS
1456{
1457 if (sym_name == NULL || name == NULL)
1458 return 0;
1459 else if (wild)
73589123 1460 return wild_match (sym_name, name) == 0;
d2e4a39e
AS
1461 else
1462 {
1463 int len_name = strlen (name);
5b4ee69b 1464
4c4b4cd2
PH
1465 return (strncmp (sym_name, name, len_name) == 0
1466 && is_name_suffix (sym_name + len_name))
1467 || (strncmp (sym_name, "_ada_", 5) == 0
1468 && strncmp (sym_name + 5, name, len_name) == 0
1469 && is_name_suffix (sym_name + len_name + 5));
d2e4a39e 1470 }
14f9c5c9 1471}
14f9c5c9 1472\f
d2e4a39e 1473
4c4b4cd2 1474 /* Arrays */
14f9c5c9 1475
28c85d6c
JB
1476/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1477 generated by the GNAT compiler to describe the index type used
1478 for each dimension of an array, check whether it follows the latest
1479 known encoding. If not, fix it up to conform to the latest encoding.
1480 Otherwise, do nothing. This function also does nothing if
1481 INDEX_DESC_TYPE is NULL.
1482
1483 The GNAT encoding used to describle the array index type evolved a bit.
1484 Initially, the information would be provided through the name of each
1485 field of the structure type only, while the type of these fields was
1486 described as unspecified and irrelevant. The debugger was then expected
1487 to perform a global type lookup using the name of that field in order
1488 to get access to the full index type description. Because these global
1489 lookups can be very expensive, the encoding was later enhanced to make
1490 the global lookup unnecessary by defining the field type as being
1491 the full index type description.
1492
1493 The purpose of this routine is to allow us to support older versions
1494 of the compiler by detecting the use of the older encoding, and by
1495 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1496 we essentially replace each field's meaningless type by the associated
1497 index subtype). */
1498
1499void
1500ada_fixup_array_indexes_type (struct type *index_desc_type)
1501{
1502 int i;
1503
1504 if (index_desc_type == NULL)
1505 return;
1506 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1507
1508 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1509 to check one field only, no need to check them all). If not, return
1510 now.
1511
1512 If our INDEX_DESC_TYPE was generated using the older encoding,
1513 the field type should be a meaningless integer type whose name
1514 is not equal to the field name. */
1515 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1516 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1517 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1518 return;
1519
1520 /* Fixup each field of INDEX_DESC_TYPE. */
1521 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1522 {
0d5cff50 1523 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1524 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1525
1526 if (raw_type)
1527 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1528 }
1529}
1530
4c4b4cd2 1531/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1532
d2e4a39e
AS
1533static char *bound_name[] = {
1534 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1535 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1536};
1537
1538/* Maximum number of array dimensions we are prepared to handle. */
1539
4c4b4cd2 1540#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1541
14f9c5c9 1542
4c4b4cd2
PH
1543/* The desc_* routines return primitive portions of array descriptors
1544 (fat pointers). */
14f9c5c9
AS
1545
1546/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1547 level of indirection, if needed. */
1548
d2e4a39e
AS
1549static struct type *
1550desc_base_type (struct type *type)
14f9c5c9
AS
1551{
1552 if (type == NULL)
1553 return NULL;
61ee279c 1554 type = ada_check_typedef (type);
720d1a40
JB
1555 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1556 type = ada_typedef_target_type (type);
1557
1265e4aa
JB
1558 if (type != NULL
1559 && (TYPE_CODE (type) == TYPE_CODE_PTR
1560 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1561 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1562 else
1563 return type;
1564}
1565
4c4b4cd2
PH
1566/* True iff TYPE indicates a "thin" array pointer type. */
1567
14f9c5c9 1568static int
d2e4a39e 1569is_thin_pntr (struct type *type)
14f9c5c9 1570{
d2e4a39e 1571 return
14f9c5c9
AS
1572 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1573 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1574}
1575
4c4b4cd2
PH
1576/* The descriptor type for thin pointer type TYPE. */
1577
d2e4a39e
AS
1578static struct type *
1579thin_descriptor_type (struct type *type)
14f9c5c9 1580{
d2e4a39e 1581 struct type *base_type = desc_base_type (type);
5b4ee69b 1582
14f9c5c9
AS
1583 if (base_type == NULL)
1584 return NULL;
1585 if (is_suffix (ada_type_name (base_type), "___XVE"))
1586 return base_type;
d2e4a39e 1587 else
14f9c5c9 1588 {
d2e4a39e 1589 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1590
14f9c5c9 1591 if (alt_type == NULL)
4c4b4cd2 1592 return base_type;
14f9c5c9 1593 else
4c4b4cd2 1594 return alt_type;
14f9c5c9
AS
1595 }
1596}
1597
4c4b4cd2
PH
1598/* A pointer to the array data for thin-pointer value VAL. */
1599
d2e4a39e
AS
1600static struct value *
1601thin_data_pntr (struct value *val)
14f9c5c9 1602{
828292f2 1603 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1604 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1605
556bdfd4
UW
1606 data_type = lookup_pointer_type (data_type);
1607
14f9c5c9 1608 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1609 return value_cast (data_type, value_copy (val));
d2e4a39e 1610 else
42ae5230 1611 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1612}
1613
4c4b4cd2
PH
1614/* True iff TYPE indicates a "thick" array pointer type. */
1615
14f9c5c9 1616static int
d2e4a39e 1617is_thick_pntr (struct type *type)
14f9c5c9
AS
1618{
1619 type = desc_base_type (type);
1620 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1621 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1622}
1623
4c4b4cd2
PH
1624/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1625 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1626
d2e4a39e
AS
1627static struct type *
1628desc_bounds_type (struct type *type)
14f9c5c9 1629{
d2e4a39e 1630 struct type *r;
14f9c5c9
AS
1631
1632 type = desc_base_type (type);
1633
1634 if (type == NULL)
1635 return NULL;
1636 else if (is_thin_pntr (type))
1637 {
1638 type = thin_descriptor_type (type);
1639 if (type == NULL)
4c4b4cd2 1640 return NULL;
14f9c5c9
AS
1641 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1642 if (r != NULL)
61ee279c 1643 return ada_check_typedef (r);
14f9c5c9
AS
1644 }
1645 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1646 {
1647 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1648 if (r != NULL)
61ee279c 1649 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1650 }
1651 return NULL;
1652}
1653
1654/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1655 one, a pointer to its bounds data. Otherwise NULL. */
1656
d2e4a39e
AS
1657static struct value *
1658desc_bounds (struct value *arr)
14f9c5c9 1659{
df407dfe 1660 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1661
d2e4a39e 1662 if (is_thin_pntr (type))
14f9c5c9 1663 {
d2e4a39e 1664 struct type *bounds_type =
4c4b4cd2 1665 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1666 LONGEST addr;
1667
4cdfadb1 1668 if (bounds_type == NULL)
323e0a4a 1669 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1670
1671 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1672 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1673 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1674 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1675 addr = value_as_long (arr);
d2e4a39e 1676 else
42ae5230 1677 addr = value_address (arr);
14f9c5c9 1678
d2e4a39e 1679 return
4c4b4cd2
PH
1680 value_from_longest (lookup_pointer_type (bounds_type),
1681 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1682 }
1683
1684 else if (is_thick_pntr (type))
05e522ef
JB
1685 {
1686 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1687 _("Bad GNAT array descriptor"));
1688 struct type *p_bounds_type = value_type (p_bounds);
1689
1690 if (p_bounds_type
1691 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1692 {
1693 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1694
1695 if (TYPE_STUB (target_type))
1696 p_bounds = value_cast (lookup_pointer_type
1697 (ada_check_typedef (target_type)),
1698 p_bounds);
1699 }
1700 else
1701 error (_("Bad GNAT array descriptor"));
1702
1703 return p_bounds;
1704 }
14f9c5c9
AS
1705 else
1706 return NULL;
1707}
1708
4c4b4cd2
PH
1709/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1710 position of the field containing the address of the bounds data. */
1711
14f9c5c9 1712static int
d2e4a39e 1713fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1714{
1715 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1716}
1717
1718/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1719 size of the field containing the address of the bounds data. */
1720
14f9c5c9 1721static int
d2e4a39e 1722fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1723{
1724 type = desc_base_type (type);
1725
d2e4a39e 1726 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1727 return TYPE_FIELD_BITSIZE (type, 1);
1728 else
61ee279c 1729 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1730}
1731
4c4b4cd2 1732/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1733 pointer to one, the type of its array data (a array-with-no-bounds type);
1734 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1735 data. */
4c4b4cd2 1736
d2e4a39e 1737static struct type *
556bdfd4 1738desc_data_target_type (struct type *type)
14f9c5c9
AS
1739{
1740 type = desc_base_type (type);
1741
4c4b4cd2 1742 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1743 if (is_thin_pntr (type))
556bdfd4 1744 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1745 else if (is_thick_pntr (type))
556bdfd4
UW
1746 {
1747 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1748
1749 if (data_type
1750 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1751 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1752 }
1753
1754 return NULL;
14f9c5c9
AS
1755}
1756
1757/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1758 its array data. */
4c4b4cd2 1759
d2e4a39e
AS
1760static struct value *
1761desc_data (struct value *arr)
14f9c5c9 1762{
df407dfe 1763 struct type *type = value_type (arr);
5b4ee69b 1764
14f9c5c9
AS
1765 if (is_thin_pntr (type))
1766 return thin_data_pntr (arr);
1767 else if (is_thick_pntr (type))
d2e4a39e 1768 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1769 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1770 else
1771 return NULL;
1772}
1773
1774
1775/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1776 position of the field containing the address of the data. */
1777
14f9c5c9 1778static int
d2e4a39e 1779fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1780{
1781 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1782}
1783
1784/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1785 size of the field containing the address of the data. */
1786
14f9c5c9 1787static int
d2e4a39e 1788fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1789{
1790 type = desc_base_type (type);
1791
1792 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1793 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1794 else
14f9c5c9
AS
1795 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1796}
1797
4c4b4cd2 1798/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1799 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1800 bound, if WHICH is 1. The first bound is I=1. */
1801
d2e4a39e
AS
1802static struct value *
1803desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1804{
d2e4a39e 1805 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1806 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1807}
1808
1809/* If BOUNDS is an array-bounds structure type, return the bit position
1810 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1811 bound, if WHICH is 1. The first bound is I=1. */
1812
14f9c5c9 1813static int
d2e4a39e 1814desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1815{
d2e4a39e 1816 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1817}
1818
1819/* If BOUNDS is an array-bounds structure type, return the bit field size
1820 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1821 bound, if WHICH is 1. The first bound is I=1. */
1822
76a01679 1823static int
d2e4a39e 1824desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1825{
1826 type = desc_base_type (type);
1827
d2e4a39e
AS
1828 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1829 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1830 else
1831 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1832}
1833
1834/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1835 Ith bound (numbering from 1). Otherwise, NULL. */
1836
d2e4a39e
AS
1837static struct type *
1838desc_index_type (struct type *type, int i)
14f9c5c9
AS
1839{
1840 type = desc_base_type (type);
1841
1842 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1843 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1844 else
14f9c5c9
AS
1845 return NULL;
1846}
1847
4c4b4cd2
PH
1848/* The number of index positions in the array-bounds type TYPE.
1849 Return 0 if TYPE is NULL. */
1850
14f9c5c9 1851static int
d2e4a39e 1852desc_arity (struct type *type)
14f9c5c9
AS
1853{
1854 type = desc_base_type (type);
1855
1856 if (type != NULL)
1857 return TYPE_NFIELDS (type) / 2;
1858 return 0;
1859}
1860
4c4b4cd2
PH
1861/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1862 an array descriptor type (representing an unconstrained array
1863 type). */
1864
76a01679
JB
1865static int
1866ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1867{
1868 if (type == NULL)
1869 return 0;
61ee279c 1870 type = ada_check_typedef (type);
4c4b4cd2 1871 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1872 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1873}
1874
52ce6436 1875/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1876 * to one. */
52ce6436 1877
2c0b251b 1878static int
52ce6436
PH
1879ada_is_array_type (struct type *type)
1880{
1881 while (type != NULL
1882 && (TYPE_CODE (type) == TYPE_CODE_PTR
1883 || TYPE_CODE (type) == TYPE_CODE_REF))
1884 type = TYPE_TARGET_TYPE (type);
1885 return ada_is_direct_array_type (type);
1886}
1887
4c4b4cd2 1888/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1889
14f9c5c9 1890int
4c4b4cd2 1891ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1892{
1893 if (type == NULL)
1894 return 0;
61ee279c 1895 type = ada_check_typedef (type);
14f9c5c9 1896 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1897 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1898 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1899 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1900}
1901
4c4b4cd2
PH
1902/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1903
14f9c5c9 1904int
4c4b4cd2 1905ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1906{
556bdfd4 1907 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1908
1909 if (type == NULL)
1910 return 0;
61ee279c 1911 type = ada_check_typedef (type);
556bdfd4
UW
1912 return (data_type != NULL
1913 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1914 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1915}
1916
1917/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1918 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1919 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1920 is still needed. */
1921
14f9c5c9 1922int
ebf56fd3 1923ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1924{
d2e4a39e 1925 return
14f9c5c9
AS
1926 type != NULL
1927 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1928 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1929 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1930 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1931}
1932
1933
4c4b4cd2 1934/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1935 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1936 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1937 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1938 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1939 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1940 a descriptor. */
d2e4a39e
AS
1941struct type *
1942ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1943{
ad82864c
JB
1944 if (ada_is_constrained_packed_array_type (value_type (arr)))
1945 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1946
df407dfe
AC
1947 if (!ada_is_array_descriptor_type (value_type (arr)))
1948 return value_type (arr);
d2e4a39e
AS
1949
1950 if (!bounds)
ad82864c
JB
1951 {
1952 struct type *array_type =
1953 ada_check_typedef (desc_data_target_type (value_type (arr)));
1954
1955 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1956 TYPE_FIELD_BITSIZE (array_type, 0) =
1957 decode_packed_array_bitsize (value_type (arr));
1958
1959 return array_type;
1960 }
14f9c5c9
AS
1961 else
1962 {
d2e4a39e 1963 struct type *elt_type;
14f9c5c9 1964 int arity;
d2e4a39e 1965 struct value *descriptor;
14f9c5c9 1966
df407dfe
AC
1967 elt_type = ada_array_element_type (value_type (arr), -1);
1968 arity = ada_array_arity (value_type (arr));
14f9c5c9 1969
d2e4a39e 1970 if (elt_type == NULL || arity == 0)
df407dfe 1971 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
1972
1973 descriptor = desc_bounds (arr);
d2e4a39e 1974 if (value_as_long (descriptor) == 0)
4c4b4cd2 1975 return NULL;
d2e4a39e 1976 while (arity > 0)
4c4b4cd2 1977 {
e9bb382b
UW
1978 struct type *range_type = alloc_type_copy (value_type (arr));
1979 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
1980 struct value *low = desc_one_bound (descriptor, arity, 0);
1981 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 1982
5b4ee69b 1983 arity -= 1;
df407dfe 1984 create_range_type (range_type, value_type (low),
529cad9c
PH
1985 longest_to_int (value_as_long (low)),
1986 longest_to_int (value_as_long (high)));
4c4b4cd2 1987 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
1988
1989 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
1990 {
1991 /* We need to store the element packed bitsize, as well as
1992 recompute the array size, because it was previously
1993 computed based on the unpacked element size. */
1994 LONGEST lo = value_as_long (low);
1995 LONGEST hi = value_as_long (high);
1996
1997 TYPE_FIELD_BITSIZE (elt_type, 0) =
1998 decode_packed_array_bitsize (value_type (arr));
1999 /* If the array has no element, then the size is already
2000 zero, and does not need to be recomputed. */
2001 if (lo < hi)
2002 {
2003 int array_bitsize =
2004 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2005
2006 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2007 }
2008 }
4c4b4cd2 2009 }
14f9c5c9
AS
2010
2011 return lookup_pointer_type (elt_type);
2012 }
2013}
2014
2015/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
2016 Otherwise, returns either a standard GDB array with bounds set
2017 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2018 GDB array. Returns NULL if ARR is a null fat pointer. */
2019
d2e4a39e
AS
2020struct value *
2021ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 2022{
df407dfe 2023 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2024 {
d2e4a39e 2025 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 2026
14f9c5c9 2027 if (arrType == NULL)
4c4b4cd2 2028 return NULL;
14f9c5c9
AS
2029 return value_cast (arrType, value_copy (desc_data (arr)));
2030 }
ad82864c
JB
2031 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2032 return decode_constrained_packed_array (arr);
14f9c5c9
AS
2033 else
2034 return arr;
2035}
2036
2037/* If ARR does not represent an array, returns ARR unchanged.
2038 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
2039 be ARR itself if it already is in the proper form). */
2040
720d1a40 2041struct value *
d2e4a39e 2042ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 2043{
df407dfe 2044 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2045 {
d2e4a39e 2046 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 2047
14f9c5c9 2048 if (arrVal == NULL)
323e0a4a 2049 error (_("Bounds unavailable for null array pointer."));
529cad9c 2050 check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
2051 return value_ind (arrVal);
2052 }
ad82864c
JB
2053 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2054 return decode_constrained_packed_array (arr);
d2e4a39e 2055 else
14f9c5c9
AS
2056 return arr;
2057}
2058
2059/* If TYPE represents a GNAT array type, return it translated to an
2060 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
2061 packing). For other types, is the identity. */
2062
d2e4a39e
AS
2063struct type *
2064ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 2065{
ad82864c
JB
2066 if (ada_is_constrained_packed_array_type (type))
2067 return decode_constrained_packed_array_type (type);
17280b9f
UW
2068
2069 if (ada_is_array_descriptor_type (type))
556bdfd4 2070 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
2071
2072 return type;
14f9c5c9
AS
2073}
2074
4c4b4cd2
PH
2075/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2076
ad82864c
JB
2077static int
2078ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
2079{
2080 if (type == NULL)
2081 return 0;
4c4b4cd2 2082 type = desc_base_type (type);
61ee279c 2083 type = ada_check_typedef (type);
d2e4a39e 2084 return
14f9c5c9
AS
2085 ada_type_name (type) != NULL
2086 && strstr (ada_type_name (type), "___XP") != NULL;
2087}
2088
ad82864c
JB
2089/* Non-zero iff TYPE represents a standard GNAT constrained
2090 packed-array type. */
2091
2092int
2093ada_is_constrained_packed_array_type (struct type *type)
2094{
2095 return ada_is_packed_array_type (type)
2096 && !ada_is_array_descriptor_type (type);
2097}
2098
2099/* Non-zero iff TYPE represents an array descriptor for a
2100 unconstrained packed-array type. */
2101
2102static int
2103ada_is_unconstrained_packed_array_type (struct type *type)
2104{
2105 return ada_is_packed_array_type (type)
2106 && ada_is_array_descriptor_type (type);
2107}
2108
2109/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2110 return the size of its elements in bits. */
2111
2112static long
2113decode_packed_array_bitsize (struct type *type)
2114{
0d5cff50
DE
2115 const char *raw_name;
2116 const char *tail;
ad82864c
JB
2117 long bits;
2118
720d1a40
JB
2119 /* Access to arrays implemented as fat pointers are encoded as a typedef
2120 of the fat pointer type. We need the name of the fat pointer type
2121 to do the decoding, so strip the typedef layer. */
2122 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2123 type = ada_typedef_target_type (type);
2124
2125 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2126 if (!raw_name)
2127 raw_name = ada_type_name (desc_base_type (type));
2128
2129 if (!raw_name)
2130 return 0;
2131
2132 tail = strstr (raw_name, "___XP");
720d1a40 2133 gdb_assert (tail != NULL);
ad82864c
JB
2134
2135 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2136 {
2137 lim_warning
2138 (_("could not understand bit size information on packed array"));
2139 return 0;
2140 }
2141
2142 return bits;
2143}
2144
14f9c5c9
AS
2145/* Given that TYPE is a standard GDB array type with all bounds filled
2146 in, and that the element size of its ultimate scalar constituents
2147 (that is, either its elements, or, if it is an array of arrays, its
2148 elements' elements, etc.) is *ELT_BITS, return an identical type,
2149 but with the bit sizes of its elements (and those of any
2150 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2
PH
2151 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2152 in bits. */
2153
d2e4a39e 2154static struct type *
ad82864c 2155constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2156{
d2e4a39e
AS
2157 struct type *new_elt_type;
2158 struct type *new_type;
99b1c762
JB
2159 struct type *index_type_desc;
2160 struct type *index_type;
14f9c5c9
AS
2161 LONGEST low_bound, high_bound;
2162
61ee279c 2163 type = ada_check_typedef (type);
14f9c5c9
AS
2164 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2165 return type;
2166
99b1c762
JB
2167 index_type_desc = ada_find_parallel_type (type, "___XA");
2168 if (index_type_desc)
2169 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2170 NULL);
2171 else
2172 index_type = TYPE_INDEX_TYPE (type);
2173
e9bb382b 2174 new_type = alloc_type_copy (type);
ad82864c
JB
2175 new_elt_type =
2176 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2177 elt_bits);
99b1c762 2178 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2179 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2180 TYPE_NAME (new_type) = ada_type_name (type);
2181
99b1c762 2182 if (get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2183 low_bound = high_bound = 0;
2184 if (high_bound < low_bound)
2185 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2186 else
14f9c5c9
AS
2187 {
2188 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2189 TYPE_LENGTH (new_type) =
4c4b4cd2 2190 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2191 }
2192
876cecd0 2193 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2194 return new_type;
2195}
2196
ad82864c
JB
2197/* The array type encoded by TYPE, where
2198 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2199
d2e4a39e 2200static struct type *
ad82864c 2201decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2202{
0d5cff50 2203 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2204 char *name;
0d5cff50 2205 const char *tail;
d2e4a39e 2206 struct type *shadow_type;
14f9c5c9 2207 long bits;
14f9c5c9 2208
727e3d2e
JB
2209 if (!raw_name)
2210 raw_name = ada_type_name (desc_base_type (type));
2211
2212 if (!raw_name)
2213 return NULL;
2214
2215 name = (char *) alloca (strlen (raw_name) + 1);
2216 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2217 type = desc_base_type (type);
2218
14f9c5c9
AS
2219 memcpy (name, raw_name, tail - raw_name);
2220 name[tail - raw_name] = '\000';
2221
b4ba55a1
JB
2222 shadow_type = ada_find_parallel_type_with_name (type, name);
2223
2224 if (shadow_type == NULL)
14f9c5c9 2225 {
323e0a4a 2226 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2227 return NULL;
2228 }
cb249c71 2229 CHECK_TYPEDEF (shadow_type);
14f9c5c9
AS
2230
2231 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2232 {
0963b4bd
MS
2233 lim_warning (_("could not understand bounds "
2234 "information on packed array"));
14f9c5c9
AS
2235 return NULL;
2236 }
d2e4a39e 2237
ad82864c
JB
2238 bits = decode_packed_array_bitsize (type);
2239 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2240}
2241
ad82864c
JB
2242/* Given that ARR is a struct value *indicating a GNAT constrained packed
2243 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2244 standard GDB array type except that the BITSIZEs of the array
2245 target types are set to the number of bits in each element, and the
4c4b4cd2 2246 type length is set appropriately. */
14f9c5c9 2247
d2e4a39e 2248static struct value *
ad82864c 2249decode_constrained_packed_array (struct value *arr)
14f9c5c9 2250{
4c4b4cd2 2251 struct type *type;
14f9c5c9 2252
4c4b4cd2 2253 arr = ada_coerce_ref (arr);
284614f0
JB
2254
2255 /* If our value is a pointer, then dererence it. Make sure that
2256 this operation does not cause the target type to be fixed, as
2257 this would indirectly cause this array to be decoded. The rest
2258 of the routine assumes that the array hasn't been decoded yet,
2259 so we use the basic "value_ind" routine to perform the dereferencing,
2260 as opposed to using "ada_value_ind". */
828292f2 2261 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2262 arr = value_ind (arr);
4c4b4cd2 2263
ad82864c 2264 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2265 if (type == NULL)
2266 {
323e0a4a 2267 error (_("can't unpack array"));
14f9c5c9
AS
2268 return NULL;
2269 }
61ee279c 2270
50810684 2271 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2272 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2273 {
2274 /* This is a (right-justified) modular type representing a packed
2275 array with no wrapper. In order to interpret the value through
2276 the (left-justified) packed array type we just built, we must
2277 first left-justify it. */
2278 int bit_size, bit_pos;
2279 ULONGEST mod;
2280
df407dfe 2281 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2282 bit_size = 0;
2283 while (mod > 0)
2284 {
2285 bit_size += 1;
2286 mod >>= 1;
2287 }
df407dfe 2288 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2289 arr = ada_value_primitive_packed_val (arr, NULL,
2290 bit_pos / HOST_CHAR_BIT,
2291 bit_pos % HOST_CHAR_BIT,
2292 bit_size,
2293 type);
2294 }
2295
4c4b4cd2 2296 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2297}
2298
2299
2300/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2301 given in IND. ARR must be a simple array. */
14f9c5c9 2302
d2e4a39e
AS
2303static struct value *
2304value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2305{
2306 int i;
2307 int bits, elt_off, bit_off;
2308 long elt_total_bit_offset;
d2e4a39e
AS
2309 struct type *elt_type;
2310 struct value *v;
14f9c5c9
AS
2311
2312 bits = 0;
2313 elt_total_bit_offset = 0;
df407dfe 2314 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2315 for (i = 0; i < arity; i += 1)
14f9c5c9 2316 {
d2e4a39e 2317 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2318 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2319 error
0963b4bd
MS
2320 (_("attempt to do packed indexing of "
2321 "something other than a packed array"));
14f9c5c9 2322 else
4c4b4cd2
PH
2323 {
2324 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2325 LONGEST lowerbound, upperbound;
2326 LONGEST idx;
2327
2328 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2329 {
323e0a4a 2330 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2331 lowerbound = upperbound = 0;
2332 }
2333
3cb382c9 2334 idx = pos_atr (ind[i]);
4c4b4cd2 2335 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2336 lim_warning (_("packed array index %ld out of bounds"),
2337 (long) idx);
4c4b4cd2
PH
2338 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2339 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2340 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2341 }
14f9c5c9
AS
2342 }
2343 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2344 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2345
2346 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2347 bits, elt_type);
14f9c5c9
AS
2348 return v;
2349}
2350
4c4b4cd2 2351/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2352
2353static int
d2e4a39e 2354has_negatives (struct type *type)
14f9c5c9 2355{
d2e4a39e
AS
2356 switch (TYPE_CODE (type))
2357 {
2358 default:
2359 return 0;
2360 case TYPE_CODE_INT:
2361 return !TYPE_UNSIGNED (type);
2362 case TYPE_CODE_RANGE:
2363 return TYPE_LOW_BOUND (type) < 0;
2364 }
14f9c5c9 2365}
d2e4a39e 2366
14f9c5c9
AS
2367
2368/* Create a new value of type TYPE from the contents of OBJ starting
2369 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2370 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
0963b4bd 2371 assigning through the result will set the field fetched from.
4c4b4cd2
PH
2372 VALADDR is ignored unless OBJ is NULL, in which case,
2373 VALADDR+OFFSET must address the start of storage containing the
2374 packed value. The value returned in this case is never an lval.
2375 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
14f9c5c9 2376
d2e4a39e 2377struct value *
fc1a4b47 2378ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
a2bd3dcd 2379 long offset, int bit_offset, int bit_size,
4c4b4cd2 2380 struct type *type)
14f9c5c9 2381{
d2e4a39e 2382 struct value *v;
4c4b4cd2
PH
2383 int src, /* Index into the source area */
2384 targ, /* Index into the target area */
2385 srcBitsLeft, /* Number of source bits left to move */
2386 nsrc, ntarg, /* Number of source and target bytes */
2387 unusedLS, /* Number of bits in next significant
2388 byte of source that are unused */
2389 accumSize; /* Number of meaningful bits in accum */
2390 unsigned char *bytes; /* First byte containing data to unpack */
d2e4a39e 2391 unsigned char *unpacked;
4c4b4cd2 2392 unsigned long accum; /* Staging area for bits being transferred */
14f9c5c9
AS
2393 unsigned char sign;
2394 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
4c4b4cd2
PH
2395 /* Transmit bytes from least to most significant; delta is the direction
2396 the indices move. */
50810684 2397 int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1;
14f9c5c9 2398
61ee279c 2399 type = ada_check_typedef (type);
14f9c5c9
AS
2400
2401 if (obj == NULL)
2402 {
2403 v = allocate_value (type);
d2e4a39e 2404 bytes = (unsigned char *) (valaddr + offset);
14f9c5c9 2405 }
9214ee5f 2406 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
14f9c5c9 2407 {
53ba8333 2408 v = value_at (type, value_address (obj));
d2e4a39e 2409 bytes = (unsigned char *) alloca (len);
53ba8333 2410 read_memory (value_address (v) + offset, bytes, len);
14f9c5c9 2411 }
d2e4a39e 2412 else
14f9c5c9
AS
2413 {
2414 v = allocate_value (type);
0fd88904 2415 bytes = (unsigned char *) value_contents (obj) + offset;
14f9c5c9 2416 }
d2e4a39e
AS
2417
2418 if (obj != NULL)
14f9c5c9 2419 {
53ba8333 2420 long new_offset = offset;
5b4ee69b 2421
74bcbdf3 2422 set_value_component_location (v, obj);
9bbda503
AC
2423 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2424 set_value_bitsize (v, bit_size);
df407dfe 2425 if (value_bitpos (v) >= HOST_CHAR_BIT)
4c4b4cd2 2426 {
53ba8333 2427 ++new_offset;
9bbda503 2428 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
4c4b4cd2 2429 }
53ba8333
JB
2430 set_value_offset (v, new_offset);
2431
2432 /* Also set the parent value. This is needed when trying to
2433 assign a new value (in inferior memory). */
2434 set_value_parent (v, obj);
14f9c5c9
AS
2435 }
2436 else
9bbda503 2437 set_value_bitsize (v, bit_size);
0fd88904 2438 unpacked = (unsigned char *) value_contents (v);
14f9c5c9
AS
2439
2440 srcBitsLeft = bit_size;
2441 nsrc = len;
2442 ntarg = TYPE_LENGTH (type);
2443 sign = 0;
2444 if (bit_size == 0)
2445 {
2446 memset (unpacked, 0, TYPE_LENGTH (type));
2447 return v;
2448 }
50810684 2449 else if (gdbarch_bits_big_endian (get_type_arch (type)))
14f9c5c9 2450 {
d2e4a39e 2451 src = len - 1;
1265e4aa
JB
2452 if (has_negatives (type)
2453 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2454 sign = ~0;
d2e4a39e
AS
2455
2456 unusedLS =
4c4b4cd2
PH
2457 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2458 % HOST_CHAR_BIT;
14f9c5c9
AS
2459
2460 switch (TYPE_CODE (type))
4c4b4cd2
PH
2461 {
2462 case TYPE_CODE_ARRAY:
2463 case TYPE_CODE_UNION:
2464 case TYPE_CODE_STRUCT:
2465 /* Non-scalar values must be aligned at a byte boundary... */
2466 accumSize =
2467 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2468 /* ... And are placed at the beginning (most-significant) bytes
2469 of the target. */
529cad9c 2470 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
0056e4d5 2471 ntarg = targ + 1;
4c4b4cd2
PH
2472 break;
2473 default:
2474 accumSize = 0;
2475 targ = TYPE_LENGTH (type) - 1;
2476 break;
2477 }
14f9c5c9 2478 }
d2e4a39e 2479 else
14f9c5c9
AS
2480 {
2481 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2482
2483 src = targ = 0;
2484 unusedLS = bit_offset;
2485 accumSize = 0;
2486
d2e4a39e 2487 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2488 sign = ~0;
14f9c5c9 2489 }
d2e4a39e 2490
14f9c5c9
AS
2491 accum = 0;
2492 while (nsrc > 0)
2493 {
2494 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2495 part of the value. */
d2e4a39e 2496 unsigned int unusedMSMask =
4c4b4cd2
PH
2497 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2498 1;
2499 /* Sign-extend bits for this byte. */
14f9c5c9 2500 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2501
d2e4a39e 2502 accum |=
4c4b4cd2 2503 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2504 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2505 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2
PH
2506 {
2507 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2508 accumSize -= HOST_CHAR_BIT;
2509 accum >>= HOST_CHAR_BIT;
2510 ntarg -= 1;
2511 targ += delta;
2512 }
14f9c5c9
AS
2513 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2514 unusedLS = 0;
2515 nsrc -= 1;
2516 src += delta;
2517 }
2518 while (ntarg > 0)
2519 {
2520 accum |= sign << accumSize;
2521 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2522 accumSize -= HOST_CHAR_BIT;
2523 accum >>= HOST_CHAR_BIT;
2524 ntarg -= 1;
2525 targ += delta;
2526 }
2527
2528 return v;
2529}
d2e4a39e 2530
14f9c5c9
AS
2531/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2532 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2533 not overlap. */
14f9c5c9 2534static void
fc1a4b47 2535move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2536 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2537{
2538 unsigned int accum, mask;
2539 int accum_bits, chunk_size;
2540
2541 target += targ_offset / HOST_CHAR_BIT;
2542 targ_offset %= HOST_CHAR_BIT;
2543 source += src_offset / HOST_CHAR_BIT;
2544 src_offset %= HOST_CHAR_BIT;
50810684 2545 if (bits_big_endian_p)
14f9c5c9
AS
2546 {
2547 accum = (unsigned char) *source;
2548 source += 1;
2549 accum_bits = HOST_CHAR_BIT - src_offset;
2550
d2e4a39e 2551 while (n > 0)
4c4b4cd2
PH
2552 {
2553 int unused_right;
5b4ee69b 2554
4c4b4cd2
PH
2555 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2556 accum_bits += HOST_CHAR_BIT;
2557 source += 1;
2558 chunk_size = HOST_CHAR_BIT - targ_offset;
2559 if (chunk_size > n)
2560 chunk_size = n;
2561 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2562 mask = ((1 << chunk_size) - 1) << unused_right;
2563 *target =
2564 (*target & ~mask)
2565 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2566 n -= chunk_size;
2567 accum_bits -= chunk_size;
2568 target += 1;
2569 targ_offset = 0;
2570 }
14f9c5c9
AS
2571 }
2572 else
2573 {
2574 accum = (unsigned char) *source >> src_offset;
2575 source += 1;
2576 accum_bits = HOST_CHAR_BIT - src_offset;
2577
d2e4a39e 2578 while (n > 0)
4c4b4cd2
PH
2579 {
2580 accum = accum + ((unsigned char) *source << accum_bits);
2581 accum_bits += HOST_CHAR_BIT;
2582 source += 1;
2583 chunk_size = HOST_CHAR_BIT - targ_offset;
2584 if (chunk_size > n)
2585 chunk_size = n;
2586 mask = ((1 << chunk_size) - 1) << targ_offset;
2587 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2588 n -= chunk_size;
2589 accum_bits -= chunk_size;
2590 accum >>= chunk_size;
2591 target += 1;
2592 targ_offset = 0;
2593 }
14f9c5c9
AS
2594 }
2595}
2596
14f9c5c9
AS
2597/* Store the contents of FROMVAL into the location of TOVAL.
2598 Return a new value with the location of TOVAL and contents of
2599 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2600 floating-point or non-scalar types. */
14f9c5c9 2601
d2e4a39e
AS
2602static struct value *
2603ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2604{
df407dfe
AC
2605 struct type *type = value_type (toval);
2606 int bits = value_bitsize (toval);
14f9c5c9 2607
52ce6436
PH
2608 toval = ada_coerce_ref (toval);
2609 fromval = ada_coerce_ref (fromval);
2610
2611 if (ada_is_direct_array_type (value_type (toval)))
2612 toval = ada_coerce_to_simple_array (toval);
2613 if (ada_is_direct_array_type (value_type (fromval)))
2614 fromval = ada_coerce_to_simple_array (fromval);
2615
88e3b34b 2616 if (!deprecated_value_modifiable (toval))
323e0a4a 2617 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2618
d2e4a39e 2619 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2620 && bits > 0
d2e4a39e 2621 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2622 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2623 {
df407dfe
AC
2624 int len = (value_bitpos (toval)
2625 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2626 int from_size;
948f8e3d 2627 gdb_byte *buffer = alloca (len);
d2e4a39e 2628 struct value *val;
42ae5230 2629 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2630
2631 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2632 fromval = value_cast (type, fromval);
14f9c5c9 2633
52ce6436 2634 read_memory (to_addr, buffer, len);
aced2898
PH
2635 from_size = value_bitsize (fromval);
2636 if (from_size == 0)
2637 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2638 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2639 move_bits (buffer, value_bitpos (toval),
50810684 2640 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2641 else
50810684
UW
2642 move_bits (buffer, value_bitpos (toval),
2643 value_contents (fromval), 0, bits, 0);
972daa01 2644 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2645
14f9c5c9 2646 val = value_copy (toval);
0fd88904 2647 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2648 TYPE_LENGTH (type));
04624583 2649 deprecated_set_value_type (val, type);
d2e4a39e 2650
14f9c5c9
AS
2651 return val;
2652 }
2653
2654 return value_assign (toval, fromval);
2655}
2656
2657
52ce6436
PH
2658/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2659 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2660 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2661 * COMPONENT, and not the inferior's memory. The current contents
2662 * of COMPONENT are ignored. */
2663static void
2664value_assign_to_component (struct value *container, struct value *component,
2665 struct value *val)
2666{
2667 LONGEST offset_in_container =
42ae5230 2668 (LONGEST) (value_address (component) - value_address (container));
52ce6436
PH
2669 int bit_offset_in_container =
2670 value_bitpos (component) - value_bitpos (container);
2671 int bits;
2672
2673 val = value_cast (value_type (component), val);
2674
2675 if (value_bitsize (component) == 0)
2676 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2677 else
2678 bits = value_bitsize (component);
2679
50810684 2680 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
52ce6436
PH
2681 move_bits (value_contents_writeable (container) + offset_in_container,
2682 value_bitpos (container) + bit_offset_in_container,
2683 value_contents (val),
2684 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
50810684 2685 bits, 1);
52ce6436
PH
2686 else
2687 move_bits (value_contents_writeable (container) + offset_in_container,
2688 value_bitpos (container) + bit_offset_in_container,
50810684 2689 value_contents (val), 0, bits, 0);
52ce6436
PH
2690}
2691
4c4b4cd2
PH
2692/* The value of the element of array ARR at the ARITY indices given in IND.
2693 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2694 thereto. */
2695
d2e4a39e
AS
2696struct value *
2697ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2698{
2699 int k;
d2e4a39e
AS
2700 struct value *elt;
2701 struct type *elt_type;
14f9c5c9
AS
2702
2703 elt = ada_coerce_to_simple_array (arr);
2704
df407dfe 2705 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2706 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2707 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2708 return value_subscript_packed (elt, arity, ind);
2709
2710 for (k = 0; k < arity; k += 1)
2711 {
2712 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2713 error (_("too many subscripts (%d expected)"), k);
2497b498 2714 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2715 }
2716 return elt;
2717}
2718
2719/* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2720 value of the element of *ARR at the ARITY indices given in
4c4b4cd2 2721 IND. Does not read the entire array into memory. */
14f9c5c9 2722
2c0b251b 2723static struct value *
d2e4a39e 2724ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
4c4b4cd2 2725 struct value **ind)
14f9c5c9
AS
2726{
2727 int k;
2728
2729 for (k = 0; k < arity; k += 1)
2730 {
2731 LONGEST lwb, upb;
14f9c5c9
AS
2732
2733 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2734 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2735 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2736 value_copy (arr));
14f9c5c9 2737 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2497b498 2738 arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
14f9c5c9
AS
2739 type = TYPE_TARGET_TYPE (type);
2740 }
2741
2742 return value_ind (arr);
2743}
2744
0b5d8877 2745/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
f5938064
JG
2746 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2747 elements starting at index LOW. The lower bound of this array is LOW, as
0963b4bd 2748 per Ada rules. */
0b5d8877 2749static struct value *
f5938064
JG
2750ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2751 int low, int high)
0b5d8877 2752{
b0dd7688 2753 struct type *type0 = ada_check_typedef (type);
6c038f32 2754 CORE_ADDR base = value_as_address (array_ptr)
b0dd7688
JB
2755 + ((low - ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0)))
2756 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
6c038f32 2757 struct type *index_type =
b0dd7688 2758 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)),
0b5d8877 2759 low, high);
6c038f32 2760 struct type *slice_type =
b0dd7688 2761 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
5b4ee69b 2762
f5938064 2763 return value_at_lazy (slice_type, base);
0b5d8877
PH
2764}
2765
2766
2767static struct value *
2768ada_value_slice (struct value *array, int low, int high)
2769{
b0dd7688 2770 struct type *type = ada_check_typedef (value_type (array));
6c038f32 2771 struct type *index_type =
0b5d8877 2772 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
6c038f32 2773 struct type *slice_type =
0b5d8877 2774 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
5b4ee69b 2775
6c038f32 2776 return value_cast (slice_type, value_slice (array, low, high - low + 1));
0b5d8877
PH
2777}
2778
14f9c5c9
AS
2779/* If type is a record type in the form of a standard GNAT array
2780 descriptor, returns the number of dimensions for type. If arr is a
2781 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2782 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2783
2784int
d2e4a39e 2785ada_array_arity (struct type *type)
14f9c5c9
AS
2786{
2787 int arity;
2788
2789 if (type == NULL)
2790 return 0;
2791
2792 type = desc_base_type (type);
2793
2794 arity = 0;
d2e4a39e 2795 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2796 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2797 else
2798 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2799 {
4c4b4cd2 2800 arity += 1;
61ee279c 2801 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2802 }
d2e4a39e 2803
14f9c5c9
AS
2804 return arity;
2805}
2806
2807/* If TYPE is a record type in the form of a standard GNAT array
2808 descriptor or a simple array type, returns the element type for
2809 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2810 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2811
d2e4a39e
AS
2812struct type *
2813ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2814{
2815 type = desc_base_type (type);
2816
d2e4a39e 2817 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2818 {
2819 int k;
d2e4a39e 2820 struct type *p_array_type;
14f9c5c9 2821
556bdfd4 2822 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
2823
2824 k = ada_array_arity (type);
2825 if (k == 0)
4c4b4cd2 2826 return NULL;
d2e4a39e 2827
4c4b4cd2 2828 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2829 if (nindices >= 0 && k > nindices)
4c4b4cd2 2830 k = nindices;
d2e4a39e 2831 while (k > 0 && p_array_type != NULL)
4c4b4cd2 2832 {
61ee279c 2833 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
2834 k -= 1;
2835 }
14f9c5c9
AS
2836 return p_array_type;
2837 }
2838 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2839 {
2840 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
2841 {
2842 type = TYPE_TARGET_TYPE (type);
2843 nindices -= 1;
2844 }
14f9c5c9
AS
2845 return type;
2846 }
2847
2848 return NULL;
2849}
2850
4c4b4cd2 2851/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
2852 Does not examine memory. Throws an error if N is invalid or TYPE
2853 is not an array type. NAME is the name of the Ada attribute being
2854 evaluated ('range, 'first, 'last, or 'length); it is used in building
2855 the error message. */
14f9c5c9 2856
1eea4ebd
UW
2857static struct type *
2858ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 2859{
4c4b4cd2
PH
2860 struct type *result_type;
2861
14f9c5c9
AS
2862 type = desc_base_type (type);
2863
1eea4ebd
UW
2864 if (n < 0 || n > ada_array_arity (type))
2865 error (_("invalid dimension number to '%s"), name);
14f9c5c9 2866
4c4b4cd2 2867 if (ada_is_simple_array_type (type))
14f9c5c9
AS
2868 {
2869 int i;
2870
2871 for (i = 1; i < n; i += 1)
4c4b4cd2 2872 type = TYPE_TARGET_TYPE (type);
262452ec 2873 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
2874 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2875 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 2876 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
2877 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2878 result_type = NULL;
14f9c5c9 2879 }
d2e4a39e 2880 else
1eea4ebd
UW
2881 {
2882 result_type = desc_index_type (desc_bounds_type (type), n);
2883 if (result_type == NULL)
2884 error (_("attempt to take bound of something that is not an array"));
2885 }
2886
2887 return result_type;
14f9c5c9
AS
2888}
2889
2890/* Given that arr is an array type, returns the lower bound of the
2891 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 2892 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
2893 array-descriptor type. It works for other arrays with bounds supplied
2894 by run-time quantities other than discriminants. */
14f9c5c9 2895
abb68b3e 2896static LONGEST
fb5e3d5c 2897ada_array_bound_from_type (struct type *arr_type, int n, int which)
14f9c5c9 2898{
8a48ac95 2899 struct type *type, *index_type_desc, *index_type;
1ce677a4 2900 int i;
262452ec
JK
2901
2902 gdb_assert (which == 0 || which == 1);
14f9c5c9 2903
ad82864c
JB
2904 if (ada_is_constrained_packed_array_type (arr_type))
2905 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 2906
4c4b4cd2 2907 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 2908 return (LONGEST) - which;
14f9c5c9
AS
2909
2910 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2911 type = TYPE_TARGET_TYPE (arr_type);
2912 else
2913 type = arr_type;
2914
2915 index_type_desc = ada_find_parallel_type (type, "___XA");
28c85d6c 2916 ada_fixup_array_indexes_type (index_type_desc);
262452ec 2917 if (index_type_desc != NULL)
28c85d6c
JB
2918 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
2919 NULL);
262452ec 2920 else
8a48ac95
JB
2921 {
2922 struct type *elt_type = check_typedef (type);
2923
2924 for (i = 1; i < n; i++)
2925 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
2926
2927 index_type = TYPE_INDEX_TYPE (elt_type);
2928 }
262452ec 2929
43bbcdc2
PH
2930 return
2931 (LONGEST) (which == 0
2932 ? ada_discrete_type_low_bound (index_type)
2933 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
2934}
2935
2936/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
2937 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2938 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 2939 supplied by run-time quantities other than discriminants. */
14f9c5c9 2940
1eea4ebd 2941static LONGEST
4dc81987 2942ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 2943{
df407dfe 2944 struct type *arr_type = value_type (arr);
14f9c5c9 2945
ad82864c
JB
2946 if (ada_is_constrained_packed_array_type (arr_type))
2947 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 2948 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 2949 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 2950 else
1eea4ebd 2951 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
2952}
2953
2954/* Given that arr is an array value, returns the length of the
2955 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
2956 supplied by run-time quantities other than discriminants.
2957 Does not work for arrays indexed by enumeration types with representation
2958 clauses at the moment. */
14f9c5c9 2959
1eea4ebd 2960static LONGEST
d2e4a39e 2961ada_array_length (struct value *arr, int n)
14f9c5c9 2962{
df407dfe 2963 struct type *arr_type = ada_check_typedef (value_type (arr));
14f9c5c9 2964
ad82864c
JB
2965 if (ada_is_constrained_packed_array_type (arr_type))
2966 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 2967
4c4b4cd2 2968 if (ada_is_simple_array_type (arr_type))
1eea4ebd
UW
2969 return (ada_array_bound_from_type (arr_type, n, 1)
2970 - ada_array_bound_from_type (arr_type, n, 0) + 1);
14f9c5c9 2971 else
1eea4ebd
UW
2972 return (value_as_long (desc_one_bound (desc_bounds (arr), n, 1))
2973 - value_as_long (desc_one_bound (desc_bounds (arr), n, 0)) + 1);
4c4b4cd2
PH
2974}
2975
2976/* An empty array whose type is that of ARR_TYPE (an array type),
2977 with bounds LOW to LOW-1. */
2978
2979static struct value *
2980empty_array (struct type *arr_type, int low)
2981{
b0dd7688 2982 struct type *arr_type0 = ada_check_typedef (arr_type);
6c038f32 2983 struct type *index_type =
b0dd7688 2984 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)),
0b5d8877 2985 low, low - 1);
b0dd7688 2986 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 2987
0b5d8877 2988 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 2989}
14f9c5c9 2990\f
d2e4a39e 2991
4c4b4cd2 2992 /* Name resolution */
14f9c5c9 2993
4c4b4cd2
PH
2994/* The "decoded" name for the user-definable Ada operator corresponding
2995 to OP. */
14f9c5c9 2996
d2e4a39e 2997static const char *
4c4b4cd2 2998ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
2999{
3000 int i;
3001
4c4b4cd2 3002 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
3003 {
3004 if (ada_opname_table[i].op == op)
4c4b4cd2 3005 return ada_opname_table[i].decoded;
14f9c5c9 3006 }
323e0a4a 3007 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
3008}
3009
3010
4c4b4cd2
PH
3011/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3012 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3013 undefined namespace) and converts operators that are
3014 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
3015 non-null, it provides a preferred result type [at the moment, only
3016 type void has any effect---causing procedures to be preferred over
3017 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 3018 return type is preferred. May change (expand) *EXP. */
14f9c5c9 3019
4c4b4cd2
PH
3020static void
3021resolve (struct expression **expp, int void_context_p)
14f9c5c9 3022{
30b15541
UW
3023 struct type *context_type = NULL;
3024 int pc = 0;
3025
3026 if (void_context_p)
3027 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3028
3029 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
3030}
3031
4c4b4cd2
PH
3032/* Resolve the operator of the subexpression beginning at
3033 position *POS of *EXPP. "Resolving" consists of replacing
3034 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3035 with their resolutions, replacing built-in operators with
3036 function calls to user-defined operators, where appropriate, and,
3037 when DEPROCEDURE_P is non-zero, converting function-valued variables
3038 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3039 are as in ada_resolve, above. */
14f9c5c9 3040
d2e4a39e 3041static struct value *
4c4b4cd2 3042resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
76a01679 3043 struct type *context_type)
14f9c5c9
AS
3044{
3045 int pc = *pos;
3046 int i;
4c4b4cd2 3047 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 3048 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
3049 struct value **argvec; /* Vector of operand types (alloca'ed). */
3050 int nargs; /* Number of operands. */
52ce6436 3051 int oplen;
14f9c5c9
AS
3052
3053 argvec = NULL;
3054 nargs = 0;
3055 exp = *expp;
3056
52ce6436
PH
3057 /* Pass one: resolve operands, saving their types and updating *pos,
3058 if needed. */
14f9c5c9
AS
3059 switch (op)
3060 {
4c4b4cd2
PH
3061 case OP_FUNCALL:
3062 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
3063 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3064 *pos += 7;
4c4b4cd2
PH
3065 else
3066 {
3067 *pos += 3;
3068 resolve_subexp (expp, pos, 0, NULL);
3069 }
3070 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
3071 break;
3072
14f9c5c9 3073 case UNOP_ADDR:
4c4b4cd2
PH
3074 *pos += 1;
3075 resolve_subexp (expp, pos, 0, NULL);
3076 break;
3077
52ce6436
PH
3078 case UNOP_QUAL:
3079 *pos += 3;
17466c1a 3080 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
3081 break;
3082
52ce6436 3083 case OP_ATR_MODULUS:
4c4b4cd2
PH
3084 case OP_ATR_SIZE:
3085 case OP_ATR_TAG:
4c4b4cd2
PH
3086 case OP_ATR_FIRST:
3087 case OP_ATR_LAST:
3088 case OP_ATR_LENGTH:
3089 case OP_ATR_POS:
3090 case OP_ATR_VAL:
4c4b4cd2
PH
3091 case OP_ATR_MIN:
3092 case OP_ATR_MAX:
52ce6436
PH
3093 case TERNOP_IN_RANGE:
3094 case BINOP_IN_BOUNDS:
3095 case UNOP_IN_RANGE:
3096 case OP_AGGREGATE:
3097 case OP_OTHERS:
3098 case OP_CHOICES:
3099 case OP_POSITIONAL:
3100 case OP_DISCRETE_RANGE:
3101 case OP_NAME:
3102 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3103 *pos += oplen;
14f9c5c9
AS
3104 break;
3105
3106 case BINOP_ASSIGN:
3107 {
4c4b4cd2
PH
3108 struct value *arg1;
3109
3110 *pos += 1;
3111 arg1 = resolve_subexp (expp, pos, 0, NULL);
3112 if (arg1 == NULL)
3113 resolve_subexp (expp, pos, 1, NULL);
3114 else
df407dfe 3115 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 3116 break;
14f9c5c9
AS
3117 }
3118
4c4b4cd2 3119 case UNOP_CAST:
4c4b4cd2
PH
3120 *pos += 3;
3121 nargs = 1;
3122 break;
14f9c5c9 3123
4c4b4cd2
PH
3124 case BINOP_ADD:
3125 case BINOP_SUB:
3126 case BINOP_MUL:
3127 case BINOP_DIV:
3128 case BINOP_REM:
3129 case BINOP_MOD:
3130 case BINOP_EXP:
3131 case BINOP_CONCAT:
3132 case BINOP_LOGICAL_AND:
3133 case BINOP_LOGICAL_OR:
3134 case BINOP_BITWISE_AND:
3135 case BINOP_BITWISE_IOR:
3136 case BINOP_BITWISE_XOR:
14f9c5c9 3137
4c4b4cd2
PH
3138 case BINOP_EQUAL:
3139 case BINOP_NOTEQUAL:
3140 case BINOP_LESS:
3141 case BINOP_GTR:
3142 case BINOP_LEQ:
3143 case BINOP_GEQ:
14f9c5c9 3144
4c4b4cd2
PH
3145 case BINOP_REPEAT:
3146 case BINOP_SUBSCRIPT:
3147 case BINOP_COMMA:
40c8aaa9
JB
3148 *pos += 1;
3149 nargs = 2;
3150 break;
14f9c5c9 3151
4c4b4cd2
PH
3152 case UNOP_NEG:
3153 case UNOP_PLUS:
3154 case UNOP_LOGICAL_NOT:
3155 case UNOP_ABS:
3156 case UNOP_IND:
3157 *pos += 1;
3158 nargs = 1;
3159 break;
14f9c5c9 3160
4c4b4cd2
PH
3161 case OP_LONG:
3162 case OP_DOUBLE:
3163 case OP_VAR_VALUE:
3164 *pos += 4;
3165 break;
14f9c5c9 3166
4c4b4cd2
PH
3167 case OP_TYPE:
3168 case OP_BOOL:
3169 case OP_LAST:
4c4b4cd2
PH
3170 case OP_INTERNALVAR:
3171 *pos += 3;
3172 break;
14f9c5c9 3173
4c4b4cd2
PH
3174 case UNOP_MEMVAL:
3175 *pos += 3;
3176 nargs = 1;
3177 break;
3178
67f3407f
DJ
3179 case OP_REGISTER:
3180 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3181 break;
3182
4c4b4cd2
PH
3183 case STRUCTOP_STRUCT:
3184 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3185 nargs = 1;
3186 break;
3187
4c4b4cd2 3188 case TERNOP_SLICE:
4c4b4cd2
PH
3189 *pos += 1;
3190 nargs = 3;
3191 break;
3192
52ce6436 3193 case OP_STRING:
14f9c5c9 3194 break;
4c4b4cd2
PH
3195
3196 default:
323e0a4a 3197 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3198 }
3199
76a01679 3200 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
4c4b4cd2
PH
3201 for (i = 0; i < nargs; i += 1)
3202 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3203 argvec[i] = NULL;
3204 exp = *expp;
3205
3206 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3207 switch (op)
3208 {
3209 default:
3210 break;
3211
14f9c5c9 3212 case OP_VAR_VALUE:
4c4b4cd2 3213 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
3214 {
3215 struct ada_symbol_info *candidates;
3216 int n_candidates;
3217
3218 n_candidates =
3219 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3220 (exp->elts[pc + 2].symbol),
3221 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3222 &candidates);
76a01679
JB
3223
3224 if (n_candidates > 1)
3225 {
3226 /* Types tend to get re-introduced locally, so if there
3227 are any local symbols that are not types, first filter
3228 out all types. */
3229 int j;
3230 for (j = 0; j < n_candidates; j += 1)
3231 switch (SYMBOL_CLASS (candidates[j].sym))
3232 {
3233 case LOC_REGISTER:
3234 case LOC_ARG:
3235 case LOC_REF_ARG:
76a01679
JB
3236 case LOC_REGPARM_ADDR:
3237 case LOC_LOCAL:
76a01679 3238 case LOC_COMPUTED:
76a01679
JB
3239 goto FoundNonType;
3240 default:
3241 break;
3242 }
3243 FoundNonType:
3244 if (j < n_candidates)
3245 {
3246 j = 0;
3247 while (j < n_candidates)
3248 {
3249 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
3250 {
3251 candidates[j] = candidates[n_candidates - 1];
3252 n_candidates -= 1;
3253 }
3254 else
3255 j += 1;
3256 }
3257 }
3258 }
3259
3260 if (n_candidates == 0)
323e0a4a 3261 error (_("No definition found for %s"),
76a01679
JB
3262 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3263 else if (n_candidates == 1)
3264 i = 0;
3265 else if (deprocedure_p
3266 && !is_nonfunction (candidates, n_candidates))
3267 {
06d5cf63
JB
3268 i = ada_resolve_function
3269 (candidates, n_candidates, NULL, 0,
3270 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3271 context_type);
76a01679 3272 if (i < 0)
323e0a4a 3273 error (_("Could not find a match for %s"),
76a01679
JB
3274 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3275 }
3276 else
3277 {
323e0a4a 3278 printf_filtered (_("Multiple matches for %s\n"),
76a01679
JB
3279 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3280 user_select_syms (candidates, n_candidates, 1);
3281 i = 0;
3282 }
3283
3284 exp->elts[pc + 1].block = candidates[i].block;
3285 exp->elts[pc + 2].symbol = candidates[i].sym;
1265e4aa
JB
3286 if (innermost_block == NULL
3287 || contained_in (candidates[i].block, innermost_block))
76a01679
JB
3288 innermost_block = candidates[i].block;
3289 }
3290
3291 if (deprocedure_p
3292 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3293 == TYPE_CODE_FUNC))
3294 {
3295 replace_operator_with_call (expp, pc, 0, 0,
3296 exp->elts[pc + 2].symbol,
3297 exp->elts[pc + 1].block);
3298 exp = *expp;
3299 }
14f9c5c9
AS
3300 break;
3301
3302 case OP_FUNCALL:
3303 {
4c4b4cd2 3304 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3305 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2
PH
3306 {
3307 struct ada_symbol_info *candidates;
3308 int n_candidates;
3309
3310 n_candidates =
76a01679
JB
3311 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3312 (exp->elts[pc + 5].symbol),
3313 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3314 &candidates);
4c4b4cd2
PH
3315 if (n_candidates == 1)
3316 i = 0;
3317 else
3318 {
06d5cf63
JB
3319 i = ada_resolve_function
3320 (candidates, n_candidates,
3321 argvec, nargs,
3322 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3323 context_type);
4c4b4cd2 3324 if (i < 0)
323e0a4a 3325 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3326 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3327 }
3328
3329 exp->elts[pc + 4].block = candidates[i].block;
3330 exp->elts[pc + 5].symbol = candidates[i].sym;
1265e4aa
JB
3331 if (innermost_block == NULL
3332 || contained_in (candidates[i].block, innermost_block))
4c4b4cd2
PH
3333 innermost_block = candidates[i].block;
3334 }
14f9c5c9
AS
3335 }
3336 break;
3337 case BINOP_ADD:
3338 case BINOP_SUB:
3339 case BINOP_MUL:
3340 case BINOP_DIV:
3341 case BINOP_REM:
3342 case BINOP_MOD:
3343 case BINOP_CONCAT:
3344 case BINOP_BITWISE_AND:
3345 case BINOP_BITWISE_IOR:
3346 case BINOP_BITWISE_XOR:
3347 case BINOP_EQUAL:
3348 case BINOP_NOTEQUAL:
3349 case BINOP_LESS:
3350 case BINOP_GTR:
3351 case BINOP_LEQ:
3352 case BINOP_GEQ:
3353 case BINOP_EXP:
3354 case UNOP_NEG:
3355 case UNOP_PLUS:
3356 case UNOP_LOGICAL_NOT:
3357 case UNOP_ABS:
3358 if (possible_user_operator_p (op, argvec))
4c4b4cd2
PH
3359 {
3360 struct ada_symbol_info *candidates;
3361 int n_candidates;
3362
3363 n_candidates =
3364 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3365 (struct block *) NULL, VAR_DOMAIN,
4eeaa230 3366 &candidates);
4c4b4cd2 3367 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
76a01679 3368 ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3369 if (i < 0)
3370 break;
3371
76a01679
JB
3372 replace_operator_with_call (expp, pc, nargs, 1,
3373 candidates[i].sym, candidates[i].block);
4c4b4cd2
PH
3374 exp = *expp;
3375 }
14f9c5c9 3376 break;
4c4b4cd2
PH
3377
3378 case OP_TYPE:
b3dbf008 3379 case OP_REGISTER:
4c4b4cd2 3380 return NULL;
14f9c5c9
AS
3381 }
3382
3383 *pos = pc;
3384 return evaluate_subexp_type (exp, pos);
3385}
3386
3387/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3388 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3389 a non-pointer. */
14f9c5c9 3390/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3391 liberal. */
14f9c5c9
AS
3392
3393static int
4dc81987 3394ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3395{
61ee279c
PH
3396 ftype = ada_check_typedef (ftype);
3397 atype = ada_check_typedef (atype);
14f9c5c9
AS
3398
3399 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3400 ftype = TYPE_TARGET_TYPE (ftype);
3401 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3402 atype = TYPE_TARGET_TYPE (atype);
3403
d2e4a39e 3404 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3405 {
3406 default:
5b3d5b7d 3407 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3408 case TYPE_CODE_PTR:
3409 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3410 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3411 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3412 else
1265e4aa
JB
3413 return (may_deref
3414 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3415 case TYPE_CODE_INT:
3416 case TYPE_CODE_ENUM:
3417 case TYPE_CODE_RANGE:
3418 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3419 {
3420 case TYPE_CODE_INT:
3421 case TYPE_CODE_ENUM:
3422 case TYPE_CODE_RANGE:
3423 return 1;
3424 default:
3425 return 0;
3426 }
14f9c5c9
AS
3427
3428 case TYPE_CODE_ARRAY:
d2e4a39e 3429 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3430 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3431
3432 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3433 if (ada_is_array_descriptor_type (ftype))
3434 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3435 || ada_is_array_descriptor_type (atype));
14f9c5c9 3436 else
4c4b4cd2
PH
3437 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3438 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3439
3440 case TYPE_CODE_UNION:
3441 case TYPE_CODE_FLT:
3442 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3443 }
3444}
3445
3446/* Return non-zero if the formals of FUNC "sufficiently match" the
3447 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3448 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3449 argument function. */
14f9c5c9
AS
3450
3451static int
d2e4a39e 3452ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3453{
3454 int i;
d2e4a39e 3455 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3456
1265e4aa
JB
3457 if (SYMBOL_CLASS (func) == LOC_CONST
3458 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3459 return (n_actuals == 0);
3460 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3461 return 0;
3462
3463 if (TYPE_NFIELDS (func_type) != n_actuals)
3464 return 0;
3465
3466 for (i = 0; i < n_actuals; i += 1)
3467 {
4c4b4cd2 3468 if (actuals[i] == NULL)
76a01679
JB
3469 return 0;
3470 else
3471 {
5b4ee69b
MS
3472 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3473 i));
df407dfe 3474 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3475
76a01679
JB
3476 if (!ada_type_match (ftype, atype, 1))
3477 return 0;
3478 }
14f9c5c9
AS
3479 }
3480 return 1;
3481}
3482
3483/* False iff function type FUNC_TYPE definitely does not produce a value
3484 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3485 FUNC_TYPE is not a valid function type with a non-null return type
3486 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3487
3488static int
d2e4a39e 3489return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3490{
d2e4a39e 3491 struct type *return_type;
14f9c5c9
AS
3492
3493 if (func_type == NULL)
3494 return 1;
3495
4c4b4cd2 3496 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3497 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3498 else
18af8284 3499 return_type = get_base_type (func_type);
14f9c5c9
AS
3500 if (return_type == NULL)
3501 return 1;
3502
18af8284 3503 context_type = get_base_type (context_type);
14f9c5c9
AS
3504
3505 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3506 return context_type == NULL || return_type == context_type;
3507 else if (context_type == NULL)
3508 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3509 else
3510 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3511}
3512
3513
4c4b4cd2 3514/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3515 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3516 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3517 that returns that type, then eliminate matches that don't. If
3518 CONTEXT_TYPE is void and there is at least one match that does not
3519 return void, eliminate all matches that do.
3520
14f9c5c9
AS
3521 Asks the user if there is more than one match remaining. Returns -1
3522 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3523 solely for messages. May re-arrange and modify SYMS in
3524 the process; the index returned is for the modified vector. */
14f9c5c9 3525
4c4b4cd2
PH
3526static int
3527ada_resolve_function (struct ada_symbol_info syms[],
3528 int nsyms, struct value **args, int nargs,
3529 const char *name, struct type *context_type)
14f9c5c9 3530{
30b15541 3531 int fallback;
14f9c5c9 3532 int k;
4c4b4cd2 3533 int m; /* Number of hits */
14f9c5c9 3534
d2e4a39e 3535 m = 0;
30b15541
UW
3536 /* In the first pass of the loop, we only accept functions matching
3537 context_type. If none are found, we add a second pass of the loop
3538 where every function is accepted. */
3539 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3540 {
3541 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3542 {
61ee279c 3543 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
4c4b4cd2
PH
3544
3545 if (ada_args_match (syms[k].sym, args, nargs)
30b15541 3546 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3547 {
3548 syms[m] = syms[k];
3549 m += 1;
3550 }
3551 }
14f9c5c9
AS
3552 }
3553
3554 if (m == 0)
3555 return -1;
3556 else if (m > 1)
3557 {
323e0a4a 3558 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3559 user_select_syms (syms, m, 1);
14f9c5c9
AS
3560 return 0;
3561 }
3562 return 0;
3563}
3564
4c4b4cd2
PH
3565/* Returns true (non-zero) iff decoded name N0 should appear before N1
3566 in a listing of choices during disambiguation (see sort_choices, below).
3567 The idea is that overloadings of a subprogram name from the
3568 same package should sort in their source order. We settle for ordering
3569 such symbols by their trailing number (__N or $N). */
3570
14f9c5c9 3571static int
0d5cff50 3572encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3573{
3574 if (N1 == NULL)
3575 return 0;
3576 else if (N0 == NULL)
3577 return 1;
3578 else
3579 {
3580 int k0, k1;
5b4ee69b 3581
d2e4a39e 3582 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3583 ;
d2e4a39e 3584 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3585 ;
d2e4a39e 3586 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3587 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3588 {
3589 int n0, n1;
5b4ee69b 3590
4c4b4cd2
PH
3591 n0 = k0;
3592 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3593 n0 -= 1;
3594 n1 = k1;
3595 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3596 n1 -= 1;
3597 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3598 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3599 }
14f9c5c9
AS
3600 return (strcmp (N0, N1) < 0);
3601 }
3602}
d2e4a39e 3603
4c4b4cd2
PH
3604/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3605 encoded names. */
3606
d2e4a39e 3607static void
4c4b4cd2 3608sort_choices (struct ada_symbol_info syms[], int nsyms)
14f9c5c9 3609{
4c4b4cd2 3610 int i;
5b4ee69b 3611
d2e4a39e 3612 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3613 {
4c4b4cd2 3614 struct ada_symbol_info sym = syms[i];
14f9c5c9
AS
3615 int j;
3616
d2e4a39e 3617 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2
PH
3618 {
3619 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3620 SYMBOL_LINKAGE_NAME (sym.sym)))
3621 break;
3622 syms[j + 1] = syms[j];
3623 }
d2e4a39e 3624 syms[j + 1] = sym;
14f9c5c9
AS
3625 }
3626}
3627
4c4b4cd2
PH
3628/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3629 by asking the user (if necessary), returning the number selected,
3630 and setting the first elements of SYMS items. Error if no symbols
3631 selected. */
14f9c5c9
AS
3632
3633/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3634 to be re-integrated one of these days. */
14f9c5c9
AS
3635
3636int
4c4b4cd2 3637user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
14f9c5c9
AS
3638{
3639 int i;
d2e4a39e 3640 int *chosen = (int *) alloca (sizeof (int) * nsyms);
14f9c5c9
AS
3641 int n_chosen;
3642 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3643 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3644
3645 if (max_results < 1)
323e0a4a 3646 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3647 if (nsyms <= 1)
3648 return nsyms;
3649
717d2f5a
JB
3650 if (select_mode == multiple_symbols_cancel)
3651 error (_("\
3652canceled because the command is ambiguous\n\
3653See set/show multiple-symbol."));
3654
3655 /* If select_mode is "all", then return all possible symbols.
3656 Only do that if more than one symbol can be selected, of course.
3657 Otherwise, display the menu as usual. */
3658 if (select_mode == multiple_symbols_all && max_results > 1)
3659 return nsyms;
3660
323e0a4a 3661 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3662 if (max_results > 1)
323e0a4a 3663 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3664
4c4b4cd2 3665 sort_choices (syms, nsyms);
14f9c5c9
AS
3666
3667 for (i = 0; i < nsyms; i += 1)
3668 {
4c4b4cd2
PH
3669 if (syms[i].sym == NULL)
3670 continue;
3671
3672 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3673 {
76a01679
JB
3674 struct symtab_and_line sal =
3675 find_function_start_sal (syms[i].sym, 1);
5b4ee69b 3676
323e0a4a
AC
3677 if (sal.symtab == NULL)
3678 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3679 i + first_choice,
3680 SYMBOL_PRINT_NAME (syms[i].sym),
3681 sal.line);
3682 else
3683 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3684 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821
JK
3685 symtab_to_filename_for_display (sal.symtab),
3686 sal.line);
4c4b4cd2
PH
3687 continue;
3688 }
d2e4a39e 3689 else
4c4b4cd2
PH
3690 {
3691 int is_enumeral =
3692 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3693 && SYMBOL_TYPE (syms[i].sym) != NULL
3694 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
210bbc17 3695 struct symtab *symtab = SYMBOL_SYMTAB (syms[i].sym);
4c4b4cd2
PH
3696
3697 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
323e0a4a 3698 printf_unfiltered (_("[%d] %s at %s:%d\n"),
4c4b4cd2
PH
3699 i + first_choice,
3700 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821
JK
3701 symtab_to_filename_for_display (symtab),
3702 SYMBOL_LINE (syms[i].sym));
76a01679
JB
3703 else if (is_enumeral
3704 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
4c4b4cd2 3705 {
a3f17187 3706 printf_unfiltered (("[%d] "), i + first_choice);
76a01679 3707 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
79d43c61 3708 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3709 printf_unfiltered (_("'(%s) (enumeral)\n"),
4c4b4cd2
PH
3710 SYMBOL_PRINT_NAME (syms[i].sym));
3711 }
3712 else if (symtab != NULL)
3713 printf_unfiltered (is_enumeral
323e0a4a
AC
3714 ? _("[%d] %s in %s (enumeral)\n")
3715 : _("[%d] %s at %s:?\n"),
4c4b4cd2
PH
3716 i + first_choice,
3717 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821 3718 symtab_to_filename_for_display (symtab));
4c4b4cd2
PH
3719 else
3720 printf_unfiltered (is_enumeral
323e0a4a
AC
3721 ? _("[%d] %s (enumeral)\n")
3722 : _("[%d] %s at ?\n"),
4c4b4cd2
PH
3723 i + first_choice,
3724 SYMBOL_PRINT_NAME (syms[i].sym));
3725 }
14f9c5c9 3726 }
d2e4a39e 3727
14f9c5c9 3728 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 3729 "overload-choice");
14f9c5c9
AS
3730
3731 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 3732 syms[i] = syms[chosen[i]];
14f9c5c9
AS
3733
3734 return n_chosen;
3735}
3736
3737/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 3738 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
3739 order in CHOICES[0 .. N-1], and return N.
3740
3741 The user types choices as a sequence of numbers on one line
3742 separated by blanks, encoding them as follows:
3743
4c4b4cd2 3744 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
3745 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3746 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3747
4c4b4cd2 3748 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
3749
3750 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 3751 prompts (for use with the -f switch). */
14f9c5c9
AS
3752
3753int
d2e4a39e 3754get_selections (int *choices, int n_choices, int max_results,
4c4b4cd2 3755 int is_all_choice, char *annotation_suffix)
14f9c5c9 3756{
d2e4a39e 3757 char *args;
0bcd0149 3758 char *prompt;
14f9c5c9
AS
3759 int n_chosen;
3760 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 3761
14f9c5c9
AS
3762 prompt = getenv ("PS2");
3763 if (prompt == NULL)
0bcd0149 3764 prompt = "> ";
14f9c5c9 3765
0bcd0149 3766 args = command_line_input (prompt, 0, annotation_suffix);
d2e4a39e 3767
14f9c5c9 3768 if (args == NULL)
323e0a4a 3769 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
3770
3771 n_chosen = 0;
76a01679 3772
4c4b4cd2
PH
3773 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3774 order, as given in args. Choices are validated. */
14f9c5c9
AS
3775 while (1)
3776 {
d2e4a39e 3777 char *args2;
14f9c5c9
AS
3778 int choice, j;
3779
0fcd72ba 3780 args = skip_spaces (args);
14f9c5c9 3781 if (*args == '\0' && n_chosen == 0)
323e0a4a 3782 error_no_arg (_("one or more choice numbers"));
14f9c5c9 3783 else if (*args == '\0')
4c4b4cd2 3784 break;
14f9c5c9
AS
3785
3786 choice = strtol (args, &args2, 10);
d2e4a39e 3787 if (args == args2 || choice < 0
4c4b4cd2 3788 || choice > n_choices + first_choice - 1)
323e0a4a 3789 error (_("Argument must be choice number"));
14f9c5c9
AS
3790 args = args2;
3791
d2e4a39e 3792 if (choice == 0)
323e0a4a 3793 error (_("cancelled"));
14f9c5c9
AS
3794
3795 if (choice < first_choice)
4c4b4cd2
PH
3796 {
3797 n_chosen = n_choices;
3798 for (j = 0; j < n_choices; j += 1)
3799 choices[j] = j;
3800 break;
3801 }
14f9c5c9
AS
3802 choice -= first_choice;
3803
d2e4a39e 3804 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
3805 {
3806 }
14f9c5c9
AS
3807
3808 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
3809 {
3810 int k;
5b4ee69b 3811
4c4b4cd2
PH
3812 for (k = n_chosen - 1; k > j; k -= 1)
3813 choices[k + 1] = choices[k];
3814 choices[j + 1] = choice;
3815 n_chosen += 1;
3816 }
14f9c5c9
AS
3817 }
3818
3819 if (n_chosen > max_results)
323e0a4a 3820 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 3821
14f9c5c9
AS
3822 return n_chosen;
3823}
3824
4c4b4cd2
PH
3825/* Replace the operator of length OPLEN at position PC in *EXPP with a call
3826 on the function identified by SYM and BLOCK, and taking NARGS
3827 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
3828
3829static void
d2e4a39e 3830replace_operator_with_call (struct expression **expp, int pc, int nargs,
4c4b4cd2 3831 int oplen, struct symbol *sym,
270140bd 3832 const struct block *block)
14f9c5c9
AS
3833{
3834 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 3835 symbol, -oplen for operator being replaced). */
d2e4a39e 3836 struct expression *newexp = (struct expression *)
8c1a34e7 3837 xzalloc (sizeof (struct expression)
4c4b4cd2 3838 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
d2e4a39e 3839 struct expression *exp = *expp;
14f9c5c9
AS
3840
3841 newexp->nelts = exp->nelts + 7 - oplen;
3842 newexp->language_defn = exp->language_defn;
3489610d 3843 newexp->gdbarch = exp->gdbarch;
14f9c5c9 3844 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 3845 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 3846 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
3847
3848 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3849 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3850
3851 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3852 newexp->elts[pc + 4].block = block;
3853 newexp->elts[pc + 5].symbol = sym;
3854
3855 *expp = newexp;
aacb1f0a 3856 xfree (exp);
d2e4a39e 3857}
14f9c5c9
AS
3858
3859/* Type-class predicates */
3860
4c4b4cd2
PH
3861/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3862 or FLOAT). */
14f9c5c9
AS
3863
3864static int
d2e4a39e 3865numeric_type_p (struct type *type)
14f9c5c9
AS
3866{
3867 if (type == NULL)
3868 return 0;
d2e4a39e
AS
3869 else
3870 {
3871 switch (TYPE_CODE (type))
4c4b4cd2
PH
3872 {
3873 case TYPE_CODE_INT:
3874 case TYPE_CODE_FLT:
3875 return 1;
3876 case TYPE_CODE_RANGE:
3877 return (type == TYPE_TARGET_TYPE (type)
3878 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3879 default:
3880 return 0;
3881 }
d2e4a39e 3882 }
14f9c5c9
AS
3883}
3884
4c4b4cd2 3885/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
3886
3887static int
d2e4a39e 3888integer_type_p (struct type *type)
14f9c5c9
AS
3889{
3890 if (type == NULL)
3891 return 0;
d2e4a39e
AS
3892 else
3893 {
3894 switch (TYPE_CODE (type))
4c4b4cd2
PH
3895 {
3896 case TYPE_CODE_INT:
3897 return 1;
3898 case TYPE_CODE_RANGE:
3899 return (type == TYPE_TARGET_TYPE (type)
3900 || integer_type_p (TYPE_TARGET_TYPE (type)));
3901 default:
3902 return 0;
3903 }
d2e4a39e 3904 }
14f9c5c9
AS
3905}
3906
4c4b4cd2 3907/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
3908
3909static int
d2e4a39e 3910scalar_type_p (struct type *type)
14f9c5c9
AS
3911{
3912 if (type == NULL)
3913 return 0;
d2e4a39e
AS
3914 else
3915 {
3916 switch (TYPE_CODE (type))
4c4b4cd2
PH
3917 {
3918 case TYPE_CODE_INT:
3919 case TYPE_CODE_RANGE:
3920 case TYPE_CODE_ENUM:
3921 case TYPE_CODE_FLT:
3922 return 1;
3923 default:
3924 return 0;
3925 }
d2e4a39e 3926 }
14f9c5c9
AS
3927}
3928
4c4b4cd2 3929/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
3930
3931static int
d2e4a39e 3932discrete_type_p (struct type *type)
14f9c5c9
AS
3933{
3934 if (type == NULL)
3935 return 0;
d2e4a39e
AS
3936 else
3937 {
3938 switch (TYPE_CODE (type))
4c4b4cd2
PH
3939 {
3940 case TYPE_CODE_INT:
3941 case TYPE_CODE_RANGE:
3942 case TYPE_CODE_ENUM:
872f0337 3943 case TYPE_CODE_BOOL:
4c4b4cd2
PH
3944 return 1;
3945 default:
3946 return 0;
3947 }
d2e4a39e 3948 }
14f9c5c9
AS
3949}
3950
4c4b4cd2
PH
3951/* Returns non-zero if OP with operands in the vector ARGS could be
3952 a user-defined function. Errs on the side of pre-defined operators
3953 (i.e., result 0). */
14f9c5c9
AS
3954
3955static int
d2e4a39e 3956possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 3957{
76a01679 3958 struct type *type0 =
df407dfe 3959 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 3960 struct type *type1 =
df407dfe 3961 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 3962
4c4b4cd2
PH
3963 if (type0 == NULL)
3964 return 0;
3965
14f9c5c9
AS
3966 switch (op)
3967 {
3968 default:
3969 return 0;
3970
3971 case BINOP_ADD:
3972 case BINOP_SUB:
3973 case BINOP_MUL:
3974 case BINOP_DIV:
d2e4a39e 3975 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
3976
3977 case BINOP_REM:
3978 case BINOP_MOD:
3979 case BINOP_BITWISE_AND:
3980 case BINOP_BITWISE_IOR:
3981 case BINOP_BITWISE_XOR:
d2e4a39e 3982 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3983
3984 case BINOP_EQUAL:
3985 case BINOP_NOTEQUAL:
3986 case BINOP_LESS:
3987 case BINOP_GTR:
3988 case BINOP_LEQ:
3989 case BINOP_GEQ:
d2e4a39e 3990 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
3991
3992 case BINOP_CONCAT:
ee90b9ab 3993 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
3994
3995 case BINOP_EXP:
d2e4a39e 3996 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3997
3998 case UNOP_NEG:
3999 case UNOP_PLUS:
4000 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
4001 case UNOP_ABS:
4002 return (!numeric_type_p (type0));
14f9c5c9
AS
4003
4004 }
4005}
4006\f
4c4b4cd2 4007 /* Renaming */
14f9c5c9 4008
aeb5907d
JB
4009/* NOTES:
4010
4011 1. In the following, we assume that a renaming type's name may
4012 have an ___XD suffix. It would be nice if this went away at some
4013 point.
4014 2. We handle both the (old) purely type-based representation of
4015 renamings and the (new) variable-based encoding. At some point,
4016 it is devoutly to be hoped that the former goes away
4017 (FIXME: hilfinger-2007-07-09).
4018 3. Subprogram renamings are not implemented, although the XRS
4019 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4020
4021/* If SYM encodes a renaming,
4022
4023 <renaming> renames <renamed entity>,
4024
4025 sets *LEN to the length of the renamed entity's name,
4026 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4027 the string describing the subcomponent selected from the renamed
0963b4bd 4028 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
4029 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4030 are undefined). Otherwise, returns a value indicating the category
4031 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4032 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4033 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4034 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4035 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4036 may be NULL, in which case they are not assigned.
4037
4038 [Currently, however, GCC does not generate subprogram renamings.] */
4039
4040enum ada_renaming_category
4041ada_parse_renaming (struct symbol *sym,
4042 const char **renamed_entity, int *len,
4043 const char **renaming_expr)
4044{
4045 enum ada_renaming_category kind;
4046 const char *info;
4047 const char *suffix;
4048
4049 if (sym == NULL)
4050 return ADA_NOT_RENAMING;
4051 switch (SYMBOL_CLASS (sym))
14f9c5c9 4052 {
aeb5907d
JB
4053 default:
4054 return ADA_NOT_RENAMING;
4055 case LOC_TYPEDEF:
4056 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4057 renamed_entity, len, renaming_expr);
4058 case LOC_LOCAL:
4059 case LOC_STATIC:
4060 case LOC_COMPUTED:
4061 case LOC_OPTIMIZED_OUT:
4062 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4063 if (info == NULL)
4064 return ADA_NOT_RENAMING;
4065 switch (info[5])
4066 {
4067 case '_':
4068 kind = ADA_OBJECT_RENAMING;
4069 info += 6;
4070 break;
4071 case 'E':
4072 kind = ADA_EXCEPTION_RENAMING;
4073 info += 7;
4074 break;
4075 case 'P':
4076 kind = ADA_PACKAGE_RENAMING;
4077 info += 7;
4078 break;
4079 case 'S':
4080 kind = ADA_SUBPROGRAM_RENAMING;
4081 info += 7;
4082 break;
4083 default:
4084 return ADA_NOT_RENAMING;
4085 }
14f9c5c9 4086 }
4c4b4cd2 4087
aeb5907d
JB
4088 if (renamed_entity != NULL)
4089 *renamed_entity = info;
4090 suffix = strstr (info, "___XE");
4091 if (suffix == NULL || suffix == info)
4092 return ADA_NOT_RENAMING;
4093 if (len != NULL)
4094 *len = strlen (info) - strlen (suffix);
4095 suffix += 5;
4096 if (renaming_expr != NULL)
4097 *renaming_expr = suffix;
4098 return kind;
4099}
4100
4101/* Assuming TYPE encodes a renaming according to the old encoding in
4102 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4103 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4104 ADA_NOT_RENAMING otherwise. */
4105static enum ada_renaming_category
4106parse_old_style_renaming (struct type *type,
4107 const char **renamed_entity, int *len,
4108 const char **renaming_expr)
4109{
4110 enum ada_renaming_category kind;
4111 const char *name;
4112 const char *info;
4113 const char *suffix;
14f9c5c9 4114
aeb5907d
JB
4115 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4116 || TYPE_NFIELDS (type) != 1)
4117 return ADA_NOT_RENAMING;
14f9c5c9 4118
aeb5907d
JB
4119 name = type_name_no_tag (type);
4120 if (name == NULL)
4121 return ADA_NOT_RENAMING;
4122
4123 name = strstr (name, "___XR");
4124 if (name == NULL)
4125 return ADA_NOT_RENAMING;
4126 switch (name[5])
4127 {
4128 case '\0':
4129 case '_':
4130 kind = ADA_OBJECT_RENAMING;
4131 break;
4132 case 'E':
4133 kind = ADA_EXCEPTION_RENAMING;
4134 break;
4135 case 'P':
4136 kind = ADA_PACKAGE_RENAMING;
4137 break;
4138 case 'S':
4139 kind = ADA_SUBPROGRAM_RENAMING;
4140 break;
4141 default:
4142 return ADA_NOT_RENAMING;
4143 }
14f9c5c9 4144
aeb5907d
JB
4145 info = TYPE_FIELD_NAME (type, 0);
4146 if (info == NULL)
4147 return ADA_NOT_RENAMING;
4148 if (renamed_entity != NULL)
4149 *renamed_entity = info;
4150 suffix = strstr (info, "___XE");
4151 if (renaming_expr != NULL)
4152 *renaming_expr = suffix + 5;
4153 if (suffix == NULL || suffix == info)
4154 return ADA_NOT_RENAMING;
4155 if (len != NULL)
4156 *len = suffix - info;
4157 return kind;
a5ee536b
JB
4158}
4159
4160/* Compute the value of the given RENAMING_SYM, which is expected to
4161 be a symbol encoding a renaming expression. BLOCK is the block
4162 used to evaluate the renaming. */
52ce6436 4163
a5ee536b
JB
4164static struct value *
4165ada_read_renaming_var_value (struct symbol *renaming_sym,
4166 struct block *block)
4167{
bbc13ae3 4168 const char *sym_name;
a5ee536b
JB
4169 struct expression *expr;
4170 struct value *value;
4171 struct cleanup *old_chain = NULL;
4172
bbc13ae3 4173 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
1bb9788d 4174 expr = parse_exp_1 (&sym_name, 0, block, 0);
bbc13ae3 4175 old_chain = make_cleanup (free_current_contents, &expr);
a5ee536b
JB
4176 value = evaluate_expression (expr);
4177
4178 do_cleanups (old_chain);
4179 return value;
4180}
14f9c5c9 4181\f
d2e4a39e 4182
4c4b4cd2 4183 /* Evaluation: Function Calls */
14f9c5c9 4184
4c4b4cd2 4185/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4186 lvalues, and otherwise has the side-effect of allocating memory
4187 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4188
d2e4a39e 4189static struct value *
40bc484c 4190ensure_lval (struct value *val)
14f9c5c9 4191{
40bc484c
JB
4192 if (VALUE_LVAL (val) == not_lval
4193 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4194 {
df407dfe 4195 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4196 const CORE_ADDR addr =
4197 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4198
40bc484c 4199 set_value_address (val, addr);
a84a8a0d 4200 VALUE_LVAL (val) = lval_memory;
40bc484c 4201 write_memory (addr, value_contents (val), len);
c3e5cd34 4202 }
14f9c5c9
AS
4203
4204 return val;
4205}
4206
4207/* Return the value ACTUAL, converted to be an appropriate value for a
4208 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4209 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4210 values not residing in memory, updating it as needed. */
14f9c5c9 4211
a93c0eb6 4212struct value *
40bc484c 4213ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4214{
df407dfe 4215 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4216 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4217 struct type *formal_target =
4218 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4219 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4220 struct type *actual_target =
4221 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4222 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4223
4c4b4cd2 4224 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4225 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4226 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4227 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4228 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4229 {
a84a8a0d 4230 struct value *result;
5b4ee69b 4231
14f9c5c9 4232 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4233 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4234 result = desc_data (actual);
14f9c5c9 4235 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4236 {
4237 if (VALUE_LVAL (actual) != lval_memory)
4238 {
4239 struct value *val;
5b4ee69b 4240
df407dfe 4241 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4242 val = allocate_value (actual_type);
990a07ab 4243 memcpy ((char *) value_contents_raw (val),
0fd88904 4244 (char *) value_contents (actual),
4c4b4cd2 4245 TYPE_LENGTH (actual_type));
40bc484c 4246 actual = ensure_lval (val);
4c4b4cd2 4247 }
a84a8a0d 4248 result = value_addr (actual);
4c4b4cd2 4249 }
a84a8a0d
JB
4250 else
4251 return actual;
b1af9e97 4252 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4253 }
4254 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4255 return ada_value_ind (actual);
4256
4257 return actual;
4258}
4259
438c98a1
JB
4260/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4261 type TYPE. This is usually an inefficient no-op except on some targets
4262 (such as AVR) where the representation of a pointer and an address
4263 differs. */
4264
4265static CORE_ADDR
4266value_pointer (struct value *value, struct type *type)
4267{
4268 struct gdbarch *gdbarch = get_type_arch (type);
4269 unsigned len = TYPE_LENGTH (type);
4270 gdb_byte *buf = alloca (len);
4271 CORE_ADDR addr;
4272
4273 addr = value_address (value);
4274 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4275 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4276 return addr;
4277}
4278
14f9c5c9 4279
4c4b4cd2
PH
4280/* Push a descriptor of type TYPE for array value ARR on the stack at
4281 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4282 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4283 to-descriptor type rather than a descriptor type), a struct value *
4284 representing a pointer to this descriptor. */
14f9c5c9 4285
d2e4a39e 4286static struct value *
40bc484c 4287make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4288{
d2e4a39e
AS
4289 struct type *bounds_type = desc_bounds_type (type);
4290 struct type *desc_type = desc_base_type (type);
4291 struct value *descriptor = allocate_value (desc_type);
4292 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4293 int i;
d2e4a39e 4294
0963b4bd
MS
4295 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4296 i > 0; i -= 1)
14f9c5c9 4297 {
19f220c3
JK
4298 modify_field (value_type (bounds), value_contents_writeable (bounds),
4299 ada_array_bound (arr, i, 0),
4300 desc_bound_bitpos (bounds_type, i, 0),
4301 desc_bound_bitsize (bounds_type, i, 0));
4302 modify_field (value_type (bounds), value_contents_writeable (bounds),
4303 ada_array_bound (arr, i, 1),
4304 desc_bound_bitpos (bounds_type, i, 1),
4305 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4306 }
d2e4a39e 4307
40bc484c 4308 bounds = ensure_lval (bounds);
d2e4a39e 4309
19f220c3
JK
4310 modify_field (value_type (descriptor),
4311 value_contents_writeable (descriptor),
4312 value_pointer (ensure_lval (arr),
4313 TYPE_FIELD_TYPE (desc_type, 0)),
4314 fat_pntr_data_bitpos (desc_type),
4315 fat_pntr_data_bitsize (desc_type));
4316
4317 modify_field (value_type (descriptor),
4318 value_contents_writeable (descriptor),
4319 value_pointer (bounds,
4320 TYPE_FIELD_TYPE (desc_type, 1)),
4321 fat_pntr_bounds_bitpos (desc_type),
4322 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4323
40bc484c 4324 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4325
4326 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4327 return value_addr (descriptor);
4328 else
4329 return descriptor;
4330}
14f9c5c9 4331\f
3d9434b5
JB
4332 /* Symbol Cache Module */
4333
3d9434b5 4334/* Performance measurements made as of 2010-01-15 indicate that
ee01b665 4335 this cache does bring some noticeable improvements. Depending
3d9434b5
JB
4336 on the type of entity being printed, the cache can make it as much
4337 as an order of magnitude faster than without it.
4338
4339 The descriptive type DWARF extension has significantly reduced
4340 the need for this cache, at least when DWARF is being used. However,
4341 even in this case, some expensive name-based symbol searches are still
4342 sometimes necessary - to find an XVZ variable, mostly. */
4343
ee01b665 4344/* Initialize the contents of SYM_CACHE. */
3d9434b5 4345
ee01b665
JB
4346static void
4347ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4348{
4349 obstack_init (&sym_cache->cache_space);
4350 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4351}
3d9434b5 4352
ee01b665
JB
4353/* Free the memory used by SYM_CACHE. */
4354
4355static void
4356ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
3d9434b5 4357{
ee01b665
JB
4358 obstack_free (&sym_cache->cache_space, NULL);
4359 xfree (sym_cache);
4360}
3d9434b5 4361
ee01b665
JB
4362/* Return the symbol cache associated to the given program space PSPACE.
4363 If not allocated for this PSPACE yet, allocate and initialize one. */
3d9434b5 4364
ee01b665
JB
4365static struct ada_symbol_cache *
4366ada_get_symbol_cache (struct program_space *pspace)
4367{
4368 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4369 struct ada_symbol_cache *sym_cache = pspace_data->sym_cache;
4370
4371 if (sym_cache == NULL)
4372 {
4373 sym_cache = XCNEW (struct ada_symbol_cache);
4374 ada_init_symbol_cache (sym_cache);
4375 }
4376
4377 return sym_cache;
4378}
3d9434b5
JB
4379
4380/* Clear all entries from the symbol cache. */
4381
4382static void
4383ada_clear_symbol_cache (void)
4384{
ee01b665
JB
4385 struct ada_symbol_cache *sym_cache
4386 = ada_get_symbol_cache (current_program_space);
4387
4388 obstack_free (&sym_cache->cache_space, NULL);
4389 ada_init_symbol_cache (sym_cache);
3d9434b5
JB
4390}
4391
4392/* Search our cache for an entry matching NAME and NAMESPACE.
4393 Return it if found, or NULL otherwise. */
4394
4395static struct cache_entry **
4396find_entry (const char *name, domain_enum namespace)
4397{
ee01b665
JB
4398 struct ada_symbol_cache *sym_cache
4399 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4400 int h = msymbol_hash (name) % HASH_SIZE;
4401 struct cache_entry **e;
4402
ee01b665 4403 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
3d9434b5
JB
4404 {
4405 if (namespace == (*e)->namespace && strcmp (name, (*e)->name) == 0)
4406 return e;
4407 }
4408 return NULL;
4409}
4410
4411/* Search the symbol cache for an entry matching NAME and NAMESPACE.
4412 Return 1 if found, 0 otherwise.
4413
4414 If an entry was found and SYM is not NULL, set *SYM to the entry's
4415 SYM. Same principle for BLOCK if not NULL. */
96d887e8 4416
96d887e8
PH
4417static int
4418lookup_cached_symbol (const char *name, domain_enum namespace,
f0c5f9b2 4419 struct symbol **sym, const struct block **block)
96d887e8 4420{
3d9434b5
JB
4421 struct cache_entry **e = find_entry (name, namespace);
4422
4423 if (e == NULL)
4424 return 0;
4425 if (sym != NULL)
4426 *sym = (*e)->sym;
4427 if (block != NULL)
4428 *block = (*e)->block;
4429 return 1;
96d887e8
PH
4430}
4431
3d9434b5
JB
4432/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4433 in domain NAMESPACE, save this result in our symbol cache. */
4434
96d887e8
PH
4435static void
4436cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
270140bd 4437 const struct block *block)
96d887e8 4438{
ee01b665
JB
4439 struct ada_symbol_cache *sym_cache
4440 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4441 int h;
4442 char *copy;
4443 struct cache_entry *e;
4444
4445 /* If the symbol is a local symbol, then do not cache it, as a search
4446 for that symbol depends on the context. To determine whether
4447 the symbol is local or not, we check the block where we found it
4448 against the global and static blocks of its associated symtab. */
4449 if (sym
4450 && BLOCKVECTOR_BLOCK (BLOCKVECTOR (sym->symtab), GLOBAL_BLOCK) != block
4451 && BLOCKVECTOR_BLOCK (BLOCKVECTOR (sym->symtab), STATIC_BLOCK) != block)
4452 return;
4453
4454 h = msymbol_hash (name) % HASH_SIZE;
ee01b665
JB
4455 e = (struct cache_entry *) obstack_alloc (&sym_cache->cache_space,
4456 sizeof (*e));
4457 e->next = sym_cache->root[h];
4458 sym_cache->root[h] = e;
4459 e->name = copy = obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
3d9434b5
JB
4460 strcpy (copy, name);
4461 e->sym = sym;
4462 e->namespace = namespace;
4463 e->block = block;
96d887e8 4464}
4c4b4cd2
PH
4465\f
4466 /* Symbol Lookup */
4467
c0431670
JB
4468/* Return nonzero if wild matching should be used when searching for
4469 all symbols matching LOOKUP_NAME.
4470
4471 LOOKUP_NAME is expected to be a symbol name after transformation
4472 for Ada lookups (see ada_name_for_lookup). */
4473
4474static int
4475should_use_wild_match (const char *lookup_name)
4476{
4477 return (strstr (lookup_name, "__") == NULL);
4478}
4479
4c4b4cd2
PH
4480/* Return the result of a standard (literal, C-like) lookup of NAME in
4481 given DOMAIN, visible from lexical block BLOCK. */
4482
4483static struct symbol *
4484standard_lookup (const char *name, const struct block *block,
4485 domain_enum domain)
4486{
acbd605d
MGD
4487 /* Initialize it just to avoid a GCC false warning. */
4488 struct symbol *sym = NULL;
4c4b4cd2 4489
2570f2b7 4490 if (lookup_cached_symbol (name, domain, &sym, NULL))
4c4b4cd2 4491 return sym;
2570f2b7
UW
4492 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4493 cache_symbol (name, domain, sym, block_found);
4c4b4cd2
PH
4494 return sym;
4495}
4496
4497
4498/* Non-zero iff there is at least one non-function/non-enumeral symbol
4499 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4500 since they contend in overloading in the same way. */
4501static int
4502is_nonfunction (struct ada_symbol_info syms[], int n)
4503{
4504 int i;
4505
4506 for (i = 0; i < n; i += 1)
4507 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
4508 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
4509 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
14f9c5c9
AS
4510 return 1;
4511
4512 return 0;
4513}
4514
4515/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4516 struct types. Otherwise, they may not. */
14f9c5c9
AS
4517
4518static int
d2e4a39e 4519equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4520{
d2e4a39e 4521 if (type0 == type1)
14f9c5c9 4522 return 1;
d2e4a39e 4523 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4524 || TYPE_CODE (type0) != TYPE_CODE (type1))
4525 return 0;
d2e4a39e 4526 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4527 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4528 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4529 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4530 return 1;
d2e4a39e 4531
14f9c5c9
AS
4532 return 0;
4533}
4534
4535/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4536 no more defined than that of SYM1. */
14f9c5c9
AS
4537
4538static int
d2e4a39e 4539lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4540{
4541 if (sym0 == sym1)
4542 return 1;
176620f1 4543 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4544 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4545 return 0;
4546
d2e4a39e 4547 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4548 {
4549 case LOC_UNDEF:
4550 return 1;
4551 case LOC_TYPEDEF:
4552 {
4c4b4cd2
PH
4553 struct type *type0 = SYMBOL_TYPE (sym0);
4554 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4555 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4556 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4557 int len0 = strlen (name0);
5b4ee69b 4558
4c4b4cd2
PH
4559 return
4560 TYPE_CODE (type0) == TYPE_CODE (type1)
4561 && (equiv_types (type0, type1)
4562 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4563 && strncmp (name1 + len0, "___XV", 5) == 0));
14f9c5c9
AS
4564 }
4565 case LOC_CONST:
4566 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4567 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4568 default:
4569 return 0;
14f9c5c9
AS
4570 }
4571}
4572
4c4b4cd2
PH
4573/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4574 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4575
4576static void
76a01679
JB
4577add_defn_to_vec (struct obstack *obstackp,
4578 struct symbol *sym,
f0c5f9b2 4579 const struct block *block)
14f9c5c9
AS
4580{
4581 int i;
4c4b4cd2 4582 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4583
529cad9c
PH
4584 /* Do not try to complete stub types, as the debugger is probably
4585 already scanning all symbols matching a certain name at the
4586 time when this function is called. Trying to replace the stub
4587 type by its associated full type will cause us to restart a scan
4588 which may lead to an infinite recursion. Instead, the client
4589 collecting the matching symbols will end up collecting several
4590 matches, with at least one of them complete. It can then filter
4591 out the stub ones if needed. */
4592
4c4b4cd2
PH
4593 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4594 {
4595 if (lesseq_defined_than (sym, prevDefns[i].sym))
4596 return;
4597 else if (lesseq_defined_than (prevDefns[i].sym, sym))
4598 {
4599 prevDefns[i].sym = sym;
4600 prevDefns[i].block = block;
4c4b4cd2 4601 return;
76a01679 4602 }
4c4b4cd2
PH
4603 }
4604
4605 {
4606 struct ada_symbol_info info;
4607
4608 info.sym = sym;
4609 info.block = block;
4c4b4cd2
PH
4610 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
4611 }
4612}
4613
4614/* Number of ada_symbol_info structures currently collected in
4615 current vector in *OBSTACKP. */
4616
76a01679
JB
4617static int
4618num_defns_collected (struct obstack *obstackp)
4c4b4cd2
PH
4619{
4620 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
4621}
4622
4623/* Vector of ada_symbol_info structures currently collected in current
4624 vector in *OBSTACKP. If FINISH, close off the vector and return
4625 its final address. */
4626
76a01679 4627static struct ada_symbol_info *
4c4b4cd2
PH
4628defns_collected (struct obstack *obstackp, int finish)
4629{
4630 if (finish)
4631 return obstack_finish (obstackp);
4632 else
4633 return (struct ada_symbol_info *) obstack_base (obstackp);
4634}
4635
7c7b6655
TT
4636/* Return a bound minimal symbol matching NAME according to Ada
4637 decoding rules. Returns an invalid symbol if there is no such
4638 minimal symbol. Names prefixed with "standard__" are handled
4639 specially: "standard__" is first stripped off, and only static and
4640 global symbols are searched. */
4c4b4cd2 4641
7c7b6655 4642struct bound_minimal_symbol
96d887e8 4643ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4644{
7c7b6655 4645 struct bound_minimal_symbol result;
4c4b4cd2 4646 struct objfile *objfile;
96d887e8 4647 struct minimal_symbol *msymbol;
dc4024cd 4648 const int wild_match_p = should_use_wild_match (name);
4c4b4cd2 4649
7c7b6655
TT
4650 memset (&result, 0, sizeof (result));
4651
c0431670
JB
4652 /* Special case: If the user specifies a symbol name inside package
4653 Standard, do a non-wild matching of the symbol name without
4654 the "standard__" prefix. This was primarily introduced in order
4655 to allow the user to specifically access the standard exceptions
4656 using, for instance, Standard.Constraint_Error when Constraint_Error
4657 is ambiguous (due to the user defining its own Constraint_Error
4658 entity inside its program). */
96d887e8 4659 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
c0431670 4660 name += sizeof ("standard__") - 1;
4c4b4cd2 4661
96d887e8
PH
4662 ALL_MSYMBOLS (objfile, msymbol)
4663 {
efd66ac6 4664 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), name, wild_match_p)
96d887e8 4665 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
7c7b6655
TT
4666 {
4667 result.minsym = msymbol;
4668 result.objfile = objfile;
4669 break;
4670 }
96d887e8 4671 }
4c4b4cd2 4672
7c7b6655 4673 return result;
96d887e8 4674}
4c4b4cd2 4675
96d887e8
PH
4676/* For all subprograms that statically enclose the subprogram of the
4677 selected frame, add symbols matching identifier NAME in DOMAIN
4678 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4679 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4680 with a wildcard prefix. */
4c4b4cd2 4681
96d887e8
PH
4682static void
4683add_symbols_from_enclosing_procs (struct obstack *obstackp,
76a01679 4684 const char *name, domain_enum namespace,
48b78332 4685 int wild_match_p)
96d887e8 4686{
96d887e8 4687}
14f9c5c9 4688
96d887e8
PH
4689/* True if TYPE is definitely an artificial type supplied to a symbol
4690 for which no debugging information was given in the symbol file. */
14f9c5c9 4691
96d887e8
PH
4692static int
4693is_nondebugging_type (struct type *type)
4694{
0d5cff50 4695 const char *name = ada_type_name (type);
5b4ee69b 4696
96d887e8
PH
4697 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4698}
4c4b4cd2 4699
8f17729f
JB
4700/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4701 that are deemed "identical" for practical purposes.
4702
4703 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4704 types and that their number of enumerals is identical (in other
4705 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4706
4707static int
4708ada_identical_enum_types_p (struct type *type1, struct type *type2)
4709{
4710 int i;
4711
4712 /* The heuristic we use here is fairly conservative. We consider
4713 that 2 enumerate types are identical if they have the same
4714 number of enumerals and that all enumerals have the same
4715 underlying value and name. */
4716
4717 /* All enums in the type should have an identical underlying value. */
4718 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 4719 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
4720 return 0;
4721
4722 /* All enumerals should also have the same name (modulo any numerical
4723 suffix). */
4724 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4725 {
0d5cff50
DE
4726 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4727 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
4728 int len_1 = strlen (name_1);
4729 int len_2 = strlen (name_2);
4730
4731 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4732 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4733 if (len_1 != len_2
4734 || strncmp (TYPE_FIELD_NAME (type1, i),
4735 TYPE_FIELD_NAME (type2, i),
4736 len_1) != 0)
4737 return 0;
4738 }
4739
4740 return 1;
4741}
4742
4743/* Return nonzero if all the symbols in SYMS are all enumeral symbols
4744 that are deemed "identical" for practical purposes. Sometimes,
4745 enumerals are not strictly identical, but their types are so similar
4746 that they can be considered identical.
4747
4748 For instance, consider the following code:
4749
4750 type Color is (Black, Red, Green, Blue, White);
4751 type RGB_Color is new Color range Red .. Blue;
4752
4753 Type RGB_Color is a subrange of an implicit type which is a copy
4754 of type Color. If we call that implicit type RGB_ColorB ("B" is
4755 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4756 As a result, when an expression references any of the enumeral
4757 by name (Eg. "print green"), the expression is technically
4758 ambiguous and the user should be asked to disambiguate. But
4759 doing so would only hinder the user, since it wouldn't matter
4760 what choice he makes, the outcome would always be the same.
4761 So, for practical purposes, we consider them as the same. */
4762
4763static int
4764symbols_are_identical_enums (struct ada_symbol_info *syms, int nsyms)
4765{
4766 int i;
4767
4768 /* Before performing a thorough comparison check of each type,
4769 we perform a series of inexpensive checks. We expect that these
4770 checks will quickly fail in the vast majority of cases, and thus
4771 help prevent the unnecessary use of a more expensive comparison.
4772 Said comparison also expects us to make some of these checks
4773 (see ada_identical_enum_types_p). */
4774
4775 /* Quick check: All symbols should have an enum type. */
4776 for (i = 0; i < nsyms; i++)
4777 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM)
4778 return 0;
4779
4780 /* Quick check: They should all have the same value. */
4781 for (i = 1; i < nsyms; i++)
4782 if (SYMBOL_VALUE (syms[i].sym) != SYMBOL_VALUE (syms[0].sym))
4783 return 0;
4784
4785 /* Quick check: They should all have the same number of enumerals. */
4786 for (i = 1; i < nsyms; i++)
4787 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].sym))
4788 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].sym)))
4789 return 0;
4790
4791 /* All the sanity checks passed, so we might have a set of
4792 identical enumeration types. Perform a more complete
4793 comparison of the type of each symbol. */
4794 for (i = 1; i < nsyms; i++)
4795 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].sym),
4796 SYMBOL_TYPE (syms[0].sym)))
4797 return 0;
4798
4799 return 1;
4800}
4801
96d887e8
PH
4802/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4803 duplicate other symbols in the list (The only case I know of where
4804 this happens is when object files containing stabs-in-ecoff are
4805 linked with files containing ordinary ecoff debugging symbols (or no
4806 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4807 Returns the number of items in the modified list. */
4c4b4cd2 4808
96d887e8
PH
4809static int
4810remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4811{
4812 int i, j;
4c4b4cd2 4813
8f17729f
JB
4814 /* We should never be called with less than 2 symbols, as there
4815 cannot be any extra symbol in that case. But it's easy to
4816 handle, since we have nothing to do in that case. */
4817 if (nsyms < 2)
4818 return nsyms;
4819
96d887e8
PH
4820 i = 0;
4821 while (i < nsyms)
4822 {
a35ddb44 4823 int remove_p = 0;
339c13b6
JB
4824
4825 /* If two symbols have the same name and one of them is a stub type,
4826 the get rid of the stub. */
4827
4828 if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym))
4829 && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL)
4830 {
4831 for (j = 0; j < nsyms; j++)
4832 {
4833 if (j != i
4834 && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym))
4835 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4836 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4837 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0)
a35ddb44 4838 remove_p = 1;
339c13b6
JB
4839 }
4840 }
4841
4842 /* Two symbols with the same name, same class and same address
4843 should be identical. */
4844
4845 else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
96d887e8
PH
4846 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4847 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4848 {
4849 for (j = 0; j < nsyms; j += 1)
4850 {
4851 if (i != j
4852 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4853 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
76a01679 4854 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
96d887e8
PH
4855 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4856 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4857 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
a35ddb44 4858 remove_p = 1;
4c4b4cd2 4859 }
4c4b4cd2 4860 }
339c13b6 4861
a35ddb44 4862 if (remove_p)
339c13b6
JB
4863 {
4864 for (j = i + 1; j < nsyms; j += 1)
4865 syms[j - 1] = syms[j];
4866 nsyms -= 1;
4867 }
4868
96d887e8 4869 i += 1;
14f9c5c9 4870 }
8f17729f
JB
4871
4872 /* If all the remaining symbols are identical enumerals, then
4873 just keep the first one and discard the rest.
4874
4875 Unlike what we did previously, we do not discard any entry
4876 unless they are ALL identical. This is because the symbol
4877 comparison is not a strict comparison, but rather a practical
4878 comparison. If all symbols are considered identical, then
4879 we can just go ahead and use the first one and discard the rest.
4880 But if we cannot reduce the list to a single element, we have
4881 to ask the user to disambiguate anyways. And if we have to
4882 present a multiple-choice menu, it's less confusing if the list
4883 isn't missing some choices that were identical and yet distinct. */
4884 if (symbols_are_identical_enums (syms, nsyms))
4885 nsyms = 1;
4886
96d887e8 4887 return nsyms;
14f9c5c9
AS
4888}
4889
96d887e8
PH
4890/* Given a type that corresponds to a renaming entity, use the type name
4891 to extract the scope (package name or function name, fully qualified,
4892 and following the GNAT encoding convention) where this renaming has been
4893 defined. The string returned needs to be deallocated after use. */
4c4b4cd2 4894
96d887e8
PH
4895static char *
4896xget_renaming_scope (struct type *renaming_type)
14f9c5c9 4897{
96d887e8 4898 /* The renaming types adhere to the following convention:
0963b4bd 4899 <scope>__<rename>___<XR extension>.
96d887e8
PH
4900 So, to extract the scope, we search for the "___XR" extension,
4901 and then backtrack until we find the first "__". */
76a01679 4902
96d887e8
PH
4903 const char *name = type_name_no_tag (renaming_type);
4904 char *suffix = strstr (name, "___XR");
4905 char *last;
4906 int scope_len;
4907 char *scope;
14f9c5c9 4908
96d887e8
PH
4909 /* Now, backtrack a bit until we find the first "__". Start looking
4910 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 4911
96d887e8
PH
4912 for (last = suffix - 3; last > name; last--)
4913 if (last[0] == '_' && last[1] == '_')
4914 break;
76a01679 4915
96d887e8 4916 /* Make a copy of scope and return it. */
14f9c5c9 4917
96d887e8
PH
4918 scope_len = last - name;
4919 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
14f9c5c9 4920
96d887e8
PH
4921 strncpy (scope, name, scope_len);
4922 scope[scope_len] = '\0';
4c4b4cd2 4923
96d887e8 4924 return scope;
4c4b4cd2
PH
4925}
4926
96d887e8 4927/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 4928
96d887e8
PH
4929static int
4930is_package_name (const char *name)
4c4b4cd2 4931{
96d887e8
PH
4932 /* Here, We take advantage of the fact that no symbols are generated
4933 for packages, while symbols are generated for each function.
4934 So the condition for NAME represent a package becomes equivalent
4935 to NAME not existing in our list of symbols. There is only one
4936 small complication with library-level functions (see below). */
4c4b4cd2 4937
96d887e8 4938 char *fun_name;
76a01679 4939
96d887e8
PH
4940 /* If it is a function that has not been defined at library level,
4941 then we should be able to look it up in the symbols. */
4942 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4943 return 0;
14f9c5c9 4944
96d887e8
PH
4945 /* Library-level function names start with "_ada_". See if function
4946 "_ada_" followed by NAME can be found. */
14f9c5c9 4947
96d887e8 4948 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 4949 functions names cannot contain "__" in them. */
96d887e8
PH
4950 if (strstr (name, "__") != NULL)
4951 return 0;
4c4b4cd2 4952
b435e160 4953 fun_name = xstrprintf ("_ada_%s", name);
14f9c5c9 4954
96d887e8
PH
4955 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4956}
14f9c5c9 4957
96d887e8 4958/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 4959 not visible from FUNCTION_NAME. */
14f9c5c9 4960
96d887e8 4961static int
0d5cff50 4962old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 4963{
aeb5907d 4964 char *scope;
1509e573 4965 struct cleanup *old_chain;
aeb5907d
JB
4966
4967 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4968 return 0;
4969
4970 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
1509e573 4971 old_chain = make_cleanup (xfree, scope);
14f9c5c9 4972
96d887e8
PH
4973 /* If the rename has been defined in a package, then it is visible. */
4974 if (is_package_name (scope))
1509e573
JB
4975 {
4976 do_cleanups (old_chain);
4977 return 0;
4978 }
14f9c5c9 4979
96d887e8
PH
4980 /* Check that the rename is in the current function scope by checking
4981 that its name starts with SCOPE. */
76a01679 4982
96d887e8
PH
4983 /* If the function name starts with "_ada_", it means that it is
4984 a library-level function. Strip this prefix before doing the
4985 comparison, as the encoding for the renaming does not contain
4986 this prefix. */
4987 if (strncmp (function_name, "_ada_", 5) == 0)
4988 function_name += 5;
f26caa11 4989
1509e573
JB
4990 {
4991 int is_invisible = strncmp (function_name, scope, strlen (scope)) != 0;
4992
4993 do_cleanups (old_chain);
4994 return is_invisible;
4995 }
f26caa11
PH
4996}
4997
aeb5907d
JB
4998/* Remove entries from SYMS that corresponds to a renaming entity that
4999 is not visible from the function associated with CURRENT_BLOCK or
5000 that is superfluous due to the presence of more specific renaming
5001 information. Places surviving symbols in the initial entries of
5002 SYMS and returns the number of surviving symbols.
96d887e8
PH
5003
5004 Rationale:
aeb5907d
JB
5005 First, in cases where an object renaming is implemented as a
5006 reference variable, GNAT may produce both the actual reference
5007 variable and the renaming encoding. In this case, we discard the
5008 latter.
5009
5010 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
5011 entity. Unfortunately, STABS currently does not support the definition
5012 of types that are local to a given lexical block, so all renamings types
5013 are emitted at library level. As a consequence, if an application
5014 contains two renaming entities using the same name, and a user tries to
5015 print the value of one of these entities, the result of the ada symbol
5016 lookup will also contain the wrong renaming type.
f26caa11 5017
96d887e8
PH
5018 This function partially covers for this limitation by attempting to
5019 remove from the SYMS list renaming symbols that should be visible
5020 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5021 method with the current information available. The implementation
5022 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5023
5024 - When the user tries to print a rename in a function while there
5025 is another rename entity defined in a package: Normally, the
5026 rename in the function has precedence over the rename in the
5027 package, so the latter should be removed from the list. This is
5028 currently not the case.
5029
5030 - This function will incorrectly remove valid renames if
5031 the CURRENT_BLOCK corresponds to a function which symbol name
5032 has been changed by an "Export" pragma. As a consequence,
5033 the user will be unable to print such rename entities. */
4c4b4cd2 5034
14f9c5c9 5035static int
aeb5907d
JB
5036remove_irrelevant_renamings (struct ada_symbol_info *syms,
5037 int nsyms, const struct block *current_block)
4c4b4cd2
PH
5038{
5039 struct symbol *current_function;
0d5cff50 5040 const char *current_function_name;
4c4b4cd2 5041 int i;
aeb5907d
JB
5042 int is_new_style_renaming;
5043
5044 /* If there is both a renaming foo___XR... encoded as a variable and
5045 a simple variable foo in the same block, discard the latter.
0963b4bd 5046 First, zero out such symbols, then compress. */
aeb5907d
JB
5047 is_new_style_renaming = 0;
5048 for (i = 0; i < nsyms; i += 1)
5049 {
5050 struct symbol *sym = syms[i].sym;
270140bd 5051 const struct block *block = syms[i].block;
aeb5907d
JB
5052 const char *name;
5053 const char *suffix;
5054
5055 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5056 continue;
5057 name = SYMBOL_LINKAGE_NAME (sym);
5058 suffix = strstr (name, "___XR");
5059
5060 if (suffix != NULL)
5061 {
5062 int name_len = suffix - name;
5063 int j;
5b4ee69b 5064
aeb5907d
JB
5065 is_new_style_renaming = 1;
5066 for (j = 0; j < nsyms; j += 1)
5067 if (i != j && syms[j].sym != NULL
5068 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
5069 name_len) == 0
5070 && block == syms[j].block)
5071 syms[j].sym = NULL;
5072 }
5073 }
5074 if (is_new_style_renaming)
5075 {
5076 int j, k;
5077
5078 for (j = k = 0; j < nsyms; j += 1)
5079 if (syms[j].sym != NULL)
5080 {
5081 syms[k] = syms[j];
5082 k += 1;
5083 }
5084 return k;
5085 }
4c4b4cd2
PH
5086
5087 /* Extract the function name associated to CURRENT_BLOCK.
5088 Abort if unable to do so. */
76a01679 5089
4c4b4cd2
PH
5090 if (current_block == NULL)
5091 return nsyms;
76a01679 5092
7f0df278 5093 current_function = block_linkage_function (current_block);
4c4b4cd2
PH
5094 if (current_function == NULL)
5095 return nsyms;
5096
5097 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5098 if (current_function_name == NULL)
5099 return nsyms;
5100
5101 /* Check each of the symbols, and remove it from the list if it is
5102 a type corresponding to a renaming that is out of the scope of
5103 the current block. */
5104
5105 i = 0;
5106 while (i < nsyms)
5107 {
aeb5907d
JB
5108 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
5109 == ADA_OBJECT_RENAMING
5110 && old_renaming_is_invisible (syms[i].sym, current_function_name))
4c4b4cd2
PH
5111 {
5112 int j;
5b4ee69b 5113
aeb5907d 5114 for (j = i + 1; j < nsyms; j += 1)
76a01679 5115 syms[j - 1] = syms[j];
4c4b4cd2
PH
5116 nsyms -= 1;
5117 }
5118 else
5119 i += 1;
5120 }
5121
5122 return nsyms;
5123}
5124
339c13b6
JB
5125/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5126 whose name and domain match NAME and DOMAIN respectively.
5127 If no match was found, then extend the search to "enclosing"
5128 routines (in other words, if we're inside a nested function,
5129 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
5130 If WILD_MATCH_P is nonzero, perform the naming matching in
5131 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
5132
5133 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5134
5135static void
5136ada_add_local_symbols (struct obstack *obstackp, const char *name,
f0c5f9b2 5137 const struct block *block, domain_enum domain,
d0a8ab18 5138 int wild_match_p)
339c13b6
JB
5139{
5140 int block_depth = 0;
5141
5142 while (block != NULL)
5143 {
5144 block_depth += 1;
d0a8ab18
JB
5145 ada_add_block_symbols (obstackp, block, name, domain, NULL,
5146 wild_match_p);
339c13b6
JB
5147
5148 /* If we found a non-function match, assume that's the one. */
5149 if (is_nonfunction (defns_collected (obstackp, 0),
5150 num_defns_collected (obstackp)))
5151 return;
5152
5153 block = BLOCK_SUPERBLOCK (block);
5154 }
5155
5156 /* If no luck so far, try to find NAME as a local symbol in some lexically
5157 enclosing subprogram. */
5158 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
d0a8ab18 5159 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match_p);
339c13b6
JB
5160}
5161
ccefe4c4 5162/* An object of this type is used as the user_data argument when
40658b94 5163 calling the map_matching_symbols method. */
ccefe4c4 5164
40658b94 5165struct match_data
ccefe4c4 5166{
40658b94 5167 struct objfile *objfile;
ccefe4c4 5168 struct obstack *obstackp;
40658b94
PH
5169 struct symbol *arg_sym;
5170 int found_sym;
ccefe4c4
TT
5171};
5172
40658b94
PH
5173/* A callback for add_matching_symbols that adds SYM, found in BLOCK,
5174 to a list of symbols. DATA0 is a pointer to a struct match_data *
5175 containing the obstack that collects the symbol list, the file that SYM
5176 must come from, a flag indicating whether a non-argument symbol has
5177 been found in the current block, and the last argument symbol
5178 passed in SYM within the current block (if any). When SYM is null,
5179 marking the end of a block, the argument symbol is added if no
5180 other has been found. */
ccefe4c4 5181
40658b94
PH
5182static int
5183aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 5184{
40658b94
PH
5185 struct match_data *data = (struct match_data *) data0;
5186
5187 if (sym == NULL)
5188 {
5189 if (!data->found_sym && data->arg_sym != NULL)
5190 add_defn_to_vec (data->obstackp,
5191 fixup_symbol_section (data->arg_sym, data->objfile),
5192 block);
5193 data->found_sym = 0;
5194 data->arg_sym = NULL;
5195 }
5196 else
5197 {
5198 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5199 return 0;
5200 else if (SYMBOL_IS_ARGUMENT (sym))
5201 data->arg_sym = sym;
5202 else
5203 {
5204 data->found_sym = 1;
5205 add_defn_to_vec (data->obstackp,
5206 fixup_symbol_section (sym, data->objfile),
5207 block);
5208 }
5209 }
5210 return 0;
5211}
5212
db230ce3
JB
5213/* Implements compare_names, but only applying the comparision using
5214 the given CASING. */
5b4ee69b 5215
40658b94 5216static int
db230ce3
JB
5217compare_names_with_case (const char *string1, const char *string2,
5218 enum case_sensitivity casing)
40658b94
PH
5219{
5220 while (*string1 != '\0' && *string2 != '\0')
5221 {
db230ce3
JB
5222 char c1, c2;
5223
40658b94
PH
5224 if (isspace (*string1) || isspace (*string2))
5225 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
5226
5227 if (casing == case_sensitive_off)
5228 {
5229 c1 = tolower (*string1);
5230 c2 = tolower (*string2);
5231 }
5232 else
5233 {
5234 c1 = *string1;
5235 c2 = *string2;
5236 }
5237 if (c1 != c2)
40658b94 5238 break;
db230ce3 5239
40658b94
PH
5240 string1 += 1;
5241 string2 += 1;
5242 }
db230ce3 5243
40658b94
PH
5244 switch (*string1)
5245 {
5246 case '(':
5247 return strcmp_iw_ordered (string1, string2);
5248 case '_':
5249 if (*string2 == '\0')
5250 {
052874e8 5251 if (is_name_suffix (string1))
40658b94
PH
5252 return 0;
5253 else
1a1d5513 5254 return 1;
40658b94 5255 }
dbb8534f 5256 /* FALLTHROUGH */
40658b94
PH
5257 default:
5258 if (*string2 == '(')
5259 return strcmp_iw_ordered (string1, string2);
5260 else
db230ce3
JB
5261 {
5262 if (casing == case_sensitive_off)
5263 return tolower (*string1) - tolower (*string2);
5264 else
5265 return *string1 - *string2;
5266 }
40658b94 5267 }
ccefe4c4
TT
5268}
5269
db230ce3
JB
5270/* Compare STRING1 to STRING2, with results as for strcmp.
5271 Compatible with strcmp_iw_ordered in that...
5272
5273 strcmp_iw_ordered (STRING1, STRING2) <= 0
5274
5275 ... implies...
5276
5277 compare_names (STRING1, STRING2) <= 0
5278
5279 (they may differ as to what symbols compare equal). */
5280
5281static int
5282compare_names (const char *string1, const char *string2)
5283{
5284 int result;
5285
5286 /* Similar to what strcmp_iw_ordered does, we need to perform
5287 a case-insensitive comparison first, and only resort to
5288 a second, case-sensitive, comparison if the first one was
5289 not sufficient to differentiate the two strings. */
5290
5291 result = compare_names_with_case (string1, string2, case_sensitive_off);
5292 if (result == 0)
5293 result = compare_names_with_case (string1, string2, case_sensitive_on);
5294
5295 return result;
5296}
5297
339c13b6
JB
5298/* Add to OBSTACKP all non-local symbols whose name and domain match
5299 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
5300 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
5301
5302static void
40658b94
PH
5303add_nonlocal_symbols (struct obstack *obstackp, const char *name,
5304 domain_enum domain, int global,
5305 int is_wild_match)
339c13b6
JB
5306{
5307 struct objfile *objfile;
40658b94 5308 struct match_data data;
339c13b6 5309
6475f2fe 5310 memset (&data, 0, sizeof data);
ccefe4c4 5311 data.obstackp = obstackp;
339c13b6 5312
ccefe4c4 5313 ALL_OBJFILES (objfile)
40658b94
PH
5314 {
5315 data.objfile = objfile;
5316
5317 if (is_wild_match)
ade7ed9e 5318 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
40658b94
PH
5319 aux_add_nonlocal_symbols, &data,
5320 wild_match, NULL);
5321 else
ade7ed9e 5322 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
40658b94
PH
5323 aux_add_nonlocal_symbols, &data,
5324 full_match, compare_names);
5325 }
5326
5327 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5328 {
5329 ALL_OBJFILES (objfile)
5330 {
5331 char *name1 = alloca (strlen (name) + sizeof ("_ada_"));
5332 strcpy (name1, "_ada_");
5333 strcpy (name1 + sizeof ("_ada_") - 1, name);
5334 data.objfile = objfile;
ade7ed9e
DE
5335 objfile->sf->qf->map_matching_symbols (objfile, name1, domain,
5336 global,
0963b4bd
MS
5337 aux_add_nonlocal_symbols,
5338 &data,
40658b94
PH
5339 full_match, compare_names);
5340 }
5341 }
339c13b6
JB
5342}
5343
4eeaa230
DE
5344/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and, if full_search is
5345 non-zero, enclosing scope and in global scopes, returning the number of
5346 matches.
9f88c959 5347 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4c4b4cd2 5348 indicating the symbols found and the blocks and symbol tables (if
4eeaa230
DE
5349 any) in which they were found. This vector is transient---good only to
5350 the next call of ada_lookup_symbol_list.
5351
5352 When full_search is non-zero, any non-function/non-enumeral
4c4b4cd2
PH
5353 symbol match within the nest of blocks whose innermost member is BLOCK0,
5354 is the one match returned (no other matches in that or
d9680e73 5355 enclosing blocks is returned). If there are any matches in or
4eeaa230
DE
5356 surrounding BLOCK0, then these alone are returned.
5357
9f88c959 5358 Names prefixed with "standard__" are handled specially: "standard__"
4c4b4cd2 5359 is first stripped off, and only static and global symbols are searched. */
14f9c5c9 5360
4eeaa230
DE
5361static int
5362ada_lookup_symbol_list_worker (const char *name0, const struct block *block0,
5363 domain_enum namespace,
5364 struct ada_symbol_info **results,
5365 int full_search)
14f9c5c9
AS
5366{
5367 struct symbol *sym;
f0c5f9b2 5368 const struct block *block;
4c4b4cd2 5369 const char *name;
82ccd55e 5370 const int wild_match_p = should_use_wild_match (name0);
14f9c5c9 5371 int cacheIfUnique;
4c4b4cd2 5372 int ndefns;
14f9c5c9 5373
4c4b4cd2
PH
5374 obstack_free (&symbol_list_obstack, NULL);
5375 obstack_init (&symbol_list_obstack);
14f9c5c9 5376
14f9c5c9
AS
5377 cacheIfUnique = 0;
5378
5379 /* Search specified block and its superiors. */
5380
4c4b4cd2 5381 name = name0;
f0c5f9b2 5382 block = block0;
339c13b6
JB
5383
5384 /* Special case: If the user specifies a symbol name inside package
5385 Standard, do a non-wild matching of the symbol name without
5386 the "standard__" prefix. This was primarily introduced in order
5387 to allow the user to specifically access the standard exceptions
5388 using, for instance, Standard.Constraint_Error when Constraint_Error
5389 is ambiguous (due to the user defining its own Constraint_Error
5390 entity inside its program). */
4c4b4cd2
PH
5391 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
5392 {
4c4b4cd2
PH
5393 block = NULL;
5394 name = name0 + sizeof ("standard__") - 1;
5395 }
5396
339c13b6 5397 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5398
4eeaa230
DE
5399 if (block != NULL)
5400 {
5401 if (full_search)
5402 {
5403 ada_add_local_symbols (&symbol_list_obstack, name, block,
5404 namespace, wild_match_p);
5405 }
5406 else
5407 {
5408 /* In the !full_search case we're are being called by
5409 ada_iterate_over_symbols, and we don't want to search
5410 superblocks. */
5411 ada_add_block_symbols (&symbol_list_obstack, block, name,
5412 namespace, NULL, wild_match_p);
5413 }
5414 if (num_defns_collected (&symbol_list_obstack) > 0 || !full_search)
5415 goto done;
5416 }
d2e4a39e 5417
339c13b6
JB
5418 /* No non-global symbols found. Check our cache to see if we have
5419 already performed this search before. If we have, then return
5420 the same result. */
5421
14f9c5c9 5422 cacheIfUnique = 1;
2570f2b7 5423 if (lookup_cached_symbol (name0, namespace, &sym, &block))
4c4b4cd2
PH
5424 {
5425 if (sym != NULL)
2570f2b7 5426 add_defn_to_vec (&symbol_list_obstack, sym, block);
4c4b4cd2
PH
5427 goto done;
5428 }
14f9c5c9 5429
339c13b6
JB
5430 /* Search symbols from all global blocks. */
5431
40658b94 5432 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 1,
82ccd55e 5433 wild_match_p);
d2e4a39e 5434
4c4b4cd2 5435 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5436 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5437
4c4b4cd2 5438 if (num_defns_collected (&symbol_list_obstack) == 0)
40658b94 5439 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 0,
82ccd55e 5440 wild_match_p);
14f9c5c9 5441
4c4b4cd2
PH
5442done:
5443 ndefns = num_defns_collected (&symbol_list_obstack);
5444 *results = defns_collected (&symbol_list_obstack, 1);
5445
5446 ndefns = remove_extra_symbols (*results, ndefns);
5447
2ad01556 5448 if (ndefns == 0 && full_search)
2570f2b7 5449 cache_symbol (name0, namespace, NULL, NULL);
14f9c5c9 5450
2ad01556 5451 if (ndefns == 1 && full_search && cacheIfUnique)
2570f2b7 5452 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
14f9c5c9 5453
aeb5907d 5454 ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
14f9c5c9 5455
14f9c5c9
AS
5456 return ndefns;
5457}
5458
4eeaa230
DE
5459/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and
5460 in global scopes, returning the number of matches, and setting *RESULTS
5461 to a vector of (SYM,BLOCK) tuples.
5462 See ada_lookup_symbol_list_worker for further details. */
5463
5464int
5465ada_lookup_symbol_list (const char *name0, const struct block *block0,
5466 domain_enum domain, struct ada_symbol_info **results)
5467{
5468 return ada_lookup_symbol_list_worker (name0, block0, domain, results, 1);
5469}
5470
5471/* Implementation of the la_iterate_over_symbols method. */
5472
5473static void
5474ada_iterate_over_symbols (const struct block *block,
5475 const char *name, domain_enum domain,
5476 symbol_found_callback_ftype *callback,
5477 void *data)
5478{
5479 int ndefs, i;
5480 struct ada_symbol_info *results;
5481
5482 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5483 for (i = 0; i < ndefs; ++i)
5484 {
5485 if (! (*callback) (results[i].sym, data))
5486 break;
5487 }
5488}
5489
f8eba3c6
TT
5490/* If NAME is the name of an entity, return a string that should
5491 be used to look that entity up in Ada units. This string should
5492 be deallocated after use using xfree.
5493
5494 NAME can have any form that the "break" or "print" commands might
5495 recognize. In other words, it does not have to be the "natural"
5496 name, or the "encoded" name. */
5497
5498char *
5499ada_name_for_lookup (const char *name)
5500{
5501 char *canon;
5502 int nlen = strlen (name);
5503
5504 if (name[0] == '<' && name[nlen - 1] == '>')
5505 {
5506 canon = xmalloc (nlen - 1);
5507 memcpy (canon, name + 1, nlen - 2);
5508 canon[nlen - 2] = '\0';
5509 }
5510 else
5511 canon = xstrdup (ada_encode (ada_fold_name (name)));
5512 return canon;
5513}
5514
4e5c77fe
JB
5515/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5516 to 1, but choosing the first symbol found if there are multiple
5517 choices.
5518
5e2336be
JB
5519 The result is stored in *INFO, which must be non-NULL.
5520 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5521
5522void
5523ada_lookup_encoded_symbol (const char *name, const struct block *block,
5524 domain_enum namespace,
5e2336be 5525 struct ada_symbol_info *info)
14f9c5c9 5526{
4c4b4cd2 5527 struct ada_symbol_info *candidates;
14f9c5c9
AS
5528 int n_candidates;
5529
5e2336be
JB
5530 gdb_assert (info != NULL);
5531 memset (info, 0, sizeof (struct ada_symbol_info));
4e5c77fe 5532
4eeaa230 5533 n_candidates = ada_lookup_symbol_list (name, block, namespace, &candidates);
14f9c5c9 5534 if (n_candidates == 0)
4e5c77fe 5535 return;
4c4b4cd2 5536
5e2336be
JB
5537 *info = candidates[0];
5538 info->sym = fixup_symbol_section (info->sym, NULL);
4e5c77fe 5539}
aeb5907d
JB
5540
5541/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5542 scope and in global scopes, or NULL if none. NAME is folded and
5543 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5544 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5545 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5546
aeb5907d
JB
5547struct symbol *
5548ada_lookup_symbol (const char *name, const struct block *block0,
21b556f4 5549 domain_enum namespace, int *is_a_field_of_this)
aeb5907d 5550{
5e2336be 5551 struct ada_symbol_info info;
4e5c77fe 5552
aeb5907d
JB
5553 if (is_a_field_of_this != NULL)
5554 *is_a_field_of_this = 0;
5555
4e5c77fe 5556 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
5e2336be
JB
5557 block0, namespace, &info);
5558 return info.sym;
4c4b4cd2 5559}
14f9c5c9 5560
4c4b4cd2
PH
5561static struct symbol *
5562ada_lookup_symbol_nonlocal (const char *name,
76a01679 5563 const struct block *block,
21b556f4 5564 const domain_enum domain)
4c4b4cd2 5565{
94af9270 5566 return ada_lookup_symbol (name, block_static_block (block), domain, NULL);
14f9c5c9
AS
5567}
5568
5569
4c4b4cd2
PH
5570/* True iff STR is a possible encoded suffix of a normal Ada name
5571 that is to be ignored for matching purposes. Suffixes of parallel
5572 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5573 are given by any of the regular expressions:
4c4b4cd2 5574
babe1480
JB
5575 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5576 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5577 TKB [subprogram suffix for task bodies]
babe1480 5578 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5579 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5580
5581 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5582 match is performed. This sequence is used to differentiate homonyms,
5583 is an optional part of a valid name suffix. */
4c4b4cd2 5584
14f9c5c9 5585static int
d2e4a39e 5586is_name_suffix (const char *str)
14f9c5c9
AS
5587{
5588 int k;
4c4b4cd2
PH
5589 const char *matching;
5590 const int len = strlen (str);
5591
babe1480
JB
5592 /* Skip optional leading __[0-9]+. */
5593
4c4b4cd2
PH
5594 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5595 {
babe1480
JB
5596 str += 3;
5597 while (isdigit (str[0]))
5598 str += 1;
4c4b4cd2 5599 }
babe1480
JB
5600
5601 /* [.$][0-9]+ */
4c4b4cd2 5602
babe1480 5603 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5604 {
babe1480 5605 matching = str + 1;
4c4b4cd2
PH
5606 while (isdigit (matching[0]))
5607 matching += 1;
5608 if (matching[0] == '\0')
5609 return 1;
5610 }
5611
5612 /* ___[0-9]+ */
babe1480 5613
4c4b4cd2
PH
5614 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5615 {
5616 matching = str + 3;
5617 while (isdigit (matching[0]))
5618 matching += 1;
5619 if (matching[0] == '\0')
5620 return 1;
5621 }
5622
9ac7f98e
JB
5623 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5624
5625 if (strcmp (str, "TKB") == 0)
5626 return 1;
5627
529cad9c
PH
5628#if 0
5629 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
5630 with a N at the end. Unfortunately, the compiler uses the same
5631 convention for other internal types it creates. So treating
529cad9c 5632 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
5633 some regressions. For instance, consider the case of an enumerated
5634 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
5635 name ends with N.
5636 Having a single character like this as a suffix carrying some
0963b4bd 5637 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
5638 to be something like "_N" instead. In the meantime, do not do
5639 the following check. */
5640 /* Protected Object Subprograms */
5641 if (len == 1 && str [0] == 'N')
5642 return 1;
5643#endif
5644
5645 /* _E[0-9]+[bs]$ */
5646 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5647 {
5648 matching = str + 3;
5649 while (isdigit (matching[0]))
5650 matching += 1;
5651 if ((matching[0] == 'b' || matching[0] == 's')
5652 && matching [1] == '\0')
5653 return 1;
5654 }
5655
4c4b4cd2
PH
5656 /* ??? We should not modify STR directly, as we are doing below. This
5657 is fine in this case, but may become problematic later if we find
5658 that this alternative did not work, and want to try matching
5659 another one from the begining of STR. Since we modified it, we
5660 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
5661 if (str[0] == 'X')
5662 {
5663 str += 1;
d2e4a39e 5664 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
5665 {
5666 if (str[0] != 'n' && str[0] != 'b')
5667 return 0;
5668 str += 1;
5669 }
14f9c5c9 5670 }
babe1480 5671
14f9c5c9
AS
5672 if (str[0] == '\000')
5673 return 1;
babe1480 5674
d2e4a39e 5675 if (str[0] == '_')
14f9c5c9
AS
5676 {
5677 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 5678 return 0;
d2e4a39e 5679 if (str[2] == '_')
4c4b4cd2 5680 {
61ee279c
PH
5681 if (strcmp (str + 3, "JM") == 0)
5682 return 1;
5683 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5684 the LJM suffix in favor of the JM one. But we will
5685 still accept LJM as a valid suffix for a reasonable
5686 amount of time, just to allow ourselves to debug programs
5687 compiled using an older version of GNAT. */
4c4b4cd2
PH
5688 if (strcmp (str + 3, "LJM") == 0)
5689 return 1;
5690 if (str[3] != 'X')
5691 return 0;
1265e4aa
JB
5692 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5693 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
5694 return 1;
5695 if (str[4] == 'R' && str[5] != 'T')
5696 return 1;
5697 return 0;
5698 }
5699 if (!isdigit (str[2]))
5700 return 0;
5701 for (k = 3; str[k] != '\0'; k += 1)
5702 if (!isdigit (str[k]) && str[k] != '_')
5703 return 0;
14f9c5c9
AS
5704 return 1;
5705 }
4c4b4cd2 5706 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 5707 {
4c4b4cd2
PH
5708 for (k = 2; str[k] != '\0'; k += 1)
5709 if (!isdigit (str[k]) && str[k] != '_')
5710 return 0;
14f9c5c9
AS
5711 return 1;
5712 }
5713 return 0;
5714}
d2e4a39e 5715
aeb5907d
JB
5716/* Return non-zero if the string starting at NAME and ending before
5717 NAME_END contains no capital letters. */
529cad9c
PH
5718
5719static int
5720is_valid_name_for_wild_match (const char *name0)
5721{
5722 const char *decoded_name = ada_decode (name0);
5723 int i;
5724
5823c3ef
JB
5725 /* If the decoded name starts with an angle bracket, it means that
5726 NAME0 does not follow the GNAT encoding format. It should then
5727 not be allowed as a possible wild match. */
5728 if (decoded_name[0] == '<')
5729 return 0;
5730
529cad9c
PH
5731 for (i=0; decoded_name[i] != '\0'; i++)
5732 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5733 return 0;
5734
5735 return 1;
5736}
5737
73589123
PH
5738/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5739 that could start a simple name. Assumes that *NAMEP points into
5740 the string beginning at NAME0. */
4c4b4cd2 5741
14f9c5c9 5742static int
73589123 5743advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 5744{
73589123 5745 const char *name = *namep;
5b4ee69b 5746
5823c3ef 5747 while (1)
14f9c5c9 5748 {
aa27d0b3 5749 int t0, t1;
73589123
PH
5750
5751 t0 = *name;
5752 if (t0 == '_')
5753 {
5754 t1 = name[1];
5755 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5756 {
5757 name += 1;
5758 if (name == name0 + 5 && strncmp (name0, "_ada", 4) == 0)
5759 break;
5760 else
5761 name += 1;
5762 }
aa27d0b3
JB
5763 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5764 || name[2] == target0))
73589123
PH
5765 {
5766 name += 2;
5767 break;
5768 }
5769 else
5770 return 0;
5771 }
5772 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5773 name += 1;
5774 else
5823c3ef 5775 return 0;
73589123
PH
5776 }
5777
5778 *namep = name;
5779 return 1;
5780}
5781
5782/* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5783 informational suffixes of NAME (i.e., for which is_name_suffix is
5784 true). Assumes that PATN is a lower-cased Ada simple name. */
5785
5786static int
5787wild_match (const char *name, const char *patn)
5788{
22e048c9 5789 const char *p;
73589123
PH
5790 const char *name0 = name;
5791
5792 while (1)
5793 {
5794 const char *match = name;
5795
5796 if (*name == *patn)
5797 {
5798 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5799 if (*p != *name)
5800 break;
5801 if (*p == '\0' && is_name_suffix (name))
5802 return match != name0 && !is_valid_name_for_wild_match (name0);
5803
5804 if (name[-1] == '_')
5805 name -= 1;
5806 }
5807 if (!advance_wild_match (&name, name0, *patn))
5808 return 1;
96d887e8 5809 }
96d887e8
PH
5810}
5811
40658b94
PH
5812/* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
5813 informational suffix. */
5814
c4d840bd
PH
5815static int
5816full_match (const char *sym_name, const char *search_name)
5817{
40658b94 5818 return !match_name (sym_name, search_name, 0);
c4d840bd
PH
5819}
5820
5821
96d887e8
PH
5822/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5823 vector *defn_symbols, updating the list of symbols in OBSTACKP
0963b4bd 5824 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4eeaa230 5825 OBJFILE is the section containing BLOCK. */
96d887e8
PH
5826
5827static void
5828ada_add_block_symbols (struct obstack *obstackp,
f0c5f9b2 5829 const struct block *block, const char *name,
96d887e8 5830 domain_enum domain, struct objfile *objfile,
2570f2b7 5831 int wild)
96d887e8 5832{
8157b174 5833 struct block_iterator iter;
96d887e8
PH
5834 int name_len = strlen (name);
5835 /* A matching argument symbol, if any. */
5836 struct symbol *arg_sym;
5837 /* Set true when we find a matching non-argument symbol. */
5838 int found_sym;
5839 struct symbol *sym;
5840
5841 arg_sym = NULL;
5842 found_sym = 0;
5843 if (wild)
5844 {
8157b174
TT
5845 for (sym = block_iter_match_first (block, name, wild_match, &iter);
5846 sym != NULL; sym = block_iter_match_next (name, wild_match, &iter))
76a01679 5847 {
5eeb2539
AR
5848 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5849 SYMBOL_DOMAIN (sym), domain)
73589123 5850 && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0)
76a01679 5851 {
2a2d4dc3
AS
5852 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5853 continue;
5854 else if (SYMBOL_IS_ARGUMENT (sym))
5855 arg_sym = sym;
5856 else
5857 {
76a01679
JB
5858 found_sym = 1;
5859 add_defn_to_vec (obstackp,
5860 fixup_symbol_section (sym, objfile),
2570f2b7 5861 block);
76a01679
JB
5862 }
5863 }
5864 }
96d887e8
PH
5865 }
5866 else
5867 {
8157b174
TT
5868 for (sym = block_iter_match_first (block, name, full_match, &iter);
5869 sym != NULL; sym = block_iter_match_next (name, full_match, &iter))
76a01679 5870 {
5eeb2539
AR
5871 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5872 SYMBOL_DOMAIN (sym), domain))
76a01679 5873 {
c4d840bd
PH
5874 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5875 {
5876 if (SYMBOL_IS_ARGUMENT (sym))
5877 arg_sym = sym;
5878 else
2a2d4dc3 5879 {
c4d840bd
PH
5880 found_sym = 1;
5881 add_defn_to_vec (obstackp,
5882 fixup_symbol_section (sym, objfile),
5883 block);
2a2d4dc3 5884 }
c4d840bd 5885 }
76a01679
JB
5886 }
5887 }
96d887e8
PH
5888 }
5889
5890 if (!found_sym && arg_sym != NULL)
5891 {
76a01679
JB
5892 add_defn_to_vec (obstackp,
5893 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5894 block);
96d887e8
PH
5895 }
5896
5897 if (!wild)
5898 {
5899 arg_sym = NULL;
5900 found_sym = 0;
5901
5902 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 5903 {
5eeb2539
AR
5904 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5905 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
5906 {
5907 int cmp;
5908
5909 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5910 if (cmp == 0)
5911 {
5912 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5913 if (cmp == 0)
5914 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5915 name_len);
5916 }
5917
5918 if (cmp == 0
5919 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5920 {
2a2d4dc3
AS
5921 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5922 {
5923 if (SYMBOL_IS_ARGUMENT (sym))
5924 arg_sym = sym;
5925 else
5926 {
5927 found_sym = 1;
5928 add_defn_to_vec (obstackp,
5929 fixup_symbol_section (sym, objfile),
5930 block);
5931 }
5932 }
76a01679
JB
5933 }
5934 }
76a01679 5935 }
96d887e8
PH
5936
5937 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5938 They aren't parameters, right? */
5939 if (!found_sym && arg_sym != NULL)
5940 {
5941 add_defn_to_vec (obstackp,
76a01679 5942 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5943 block);
96d887e8
PH
5944 }
5945 }
5946}
5947\f
41d27058
JB
5948
5949 /* Symbol Completion */
5950
5951/* If SYM_NAME is a completion candidate for TEXT, return this symbol
5952 name in a form that's appropriate for the completion. The result
5953 does not need to be deallocated, but is only good until the next call.
5954
5955 TEXT_LEN is equal to the length of TEXT.
e701b3c0 5956 Perform a wild match if WILD_MATCH_P is set.
6ea35997 5957 ENCODED_P should be set if TEXT represents the start of a symbol name
41d27058
JB
5958 in its encoded form. */
5959
5960static const char *
5961symbol_completion_match (const char *sym_name,
5962 const char *text, int text_len,
6ea35997 5963 int wild_match_p, int encoded_p)
41d27058 5964{
41d27058
JB
5965 const int verbatim_match = (text[0] == '<');
5966 int match = 0;
5967
5968 if (verbatim_match)
5969 {
5970 /* Strip the leading angle bracket. */
5971 text = text + 1;
5972 text_len--;
5973 }
5974
5975 /* First, test against the fully qualified name of the symbol. */
5976
5977 if (strncmp (sym_name, text, text_len) == 0)
5978 match = 1;
5979
6ea35997 5980 if (match && !encoded_p)
41d27058
JB
5981 {
5982 /* One needed check before declaring a positive match is to verify
5983 that iff we are doing a verbatim match, the decoded version
5984 of the symbol name starts with '<'. Otherwise, this symbol name
5985 is not a suitable completion. */
5986 const char *sym_name_copy = sym_name;
5987 int has_angle_bracket;
5988
5989 sym_name = ada_decode (sym_name);
5990 has_angle_bracket = (sym_name[0] == '<');
5991 match = (has_angle_bracket == verbatim_match);
5992 sym_name = sym_name_copy;
5993 }
5994
5995 if (match && !verbatim_match)
5996 {
5997 /* When doing non-verbatim match, another check that needs to
5998 be done is to verify that the potentially matching symbol name
5999 does not include capital letters, because the ada-mode would
6000 not be able to understand these symbol names without the
6001 angle bracket notation. */
6002 const char *tmp;
6003
6004 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6005 if (*tmp != '\0')
6006 match = 0;
6007 }
6008
6009 /* Second: Try wild matching... */
6010
e701b3c0 6011 if (!match && wild_match_p)
41d27058
JB
6012 {
6013 /* Since we are doing wild matching, this means that TEXT
6014 may represent an unqualified symbol name. We therefore must
6015 also compare TEXT against the unqualified name of the symbol. */
6016 sym_name = ada_unqualified_name (ada_decode (sym_name));
6017
6018 if (strncmp (sym_name, text, text_len) == 0)
6019 match = 1;
6020 }
6021
6022 /* Finally: If we found a mach, prepare the result to return. */
6023
6024 if (!match)
6025 return NULL;
6026
6027 if (verbatim_match)
6028 sym_name = add_angle_brackets (sym_name);
6029
6ea35997 6030 if (!encoded_p)
41d27058
JB
6031 sym_name = ada_decode (sym_name);
6032
6033 return sym_name;
6034}
6035
6036/* A companion function to ada_make_symbol_completion_list().
6037 Check if SYM_NAME represents a symbol which name would be suitable
6038 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
6039 it is appended at the end of the given string vector SV.
6040
6041 ORIG_TEXT is the string original string from the user command
6042 that needs to be completed. WORD is the entire command on which
6043 completion should be performed. These two parameters are used to
6044 determine which part of the symbol name should be added to the
6045 completion vector.
c0af1706 6046 if WILD_MATCH_P is set, then wild matching is performed.
cb8e9b97 6047 ENCODED_P should be set if TEXT represents a symbol name in its
41d27058
JB
6048 encoded formed (in which case the completion should also be
6049 encoded). */
6050
6051static void
d6565258 6052symbol_completion_add (VEC(char_ptr) **sv,
41d27058
JB
6053 const char *sym_name,
6054 const char *text, int text_len,
6055 const char *orig_text, const char *word,
cb8e9b97 6056 int wild_match_p, int encoded_p)
41d27058
JB
6057{
6058 const char *match = symbol_completion_match (sym_name, text, text_len,
cb8e9b97 6059 wild_match_p, encoded_p);
41d27058
JB
6060 char *completion;
6061
6062 if (match == NULL)
6063 return;
6064
6065 /* We found a match, so add the appropriate completion to the given
6066 string vector. */
6067
6068 if (word == orig_text)
6069 {
6070 completion = xmalloc (strlen (match) + 5);
6071 strcpy (completion, match);
6072 }
6073 else if (word > orig_text)
6074 {
6075 /* Return some portion of sym_name. */
6076 completion = xmalloc (strlen (match) + 5);
6077 strcpy (completion, match + (word - orig_text));
6078 }
6079 else
6080 {
6081 /* Return some of ORIG_TEXT plus sym_name. */
6082 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
6083 strncpy (completion, word, orig_text - word);
6084 completion[orig_text - word] = '\0';
6085 strcat (completion, match);
6086 }
6087
d6565258 6088 VEC_safe_push (char_ptr, *sv, completion);
41d27058
JB
6089}
6090
ccefe4c4 6091/* An object of this type is passed as the user_data argument to the
bb4142cf 6092 expand_symtabs_matching method. */
ccefe4c4
TT
6093struct add_partial_datum
6094{
6095 VEC(char_ptr) **completions;
6f937416 6096 const char *text;
ccefe4c4 6097 int text_len;
6f937416
PA
6098 const char *text0;
6099 const char *word;
ccefe4c4
TT
6100 int wild_match;
6101 int encoded;
6102};
6103
bb4142cf
DE
6104/* A callback for expand_symtabs_matching. */
6105
7b08b9eb 6106static int
bb4142cf 6107ada_complete_symbol_matcher (const char *name, void *user_data)
ccefe4c4
TT
6108{
6109 struct add_partial_datum *data = user_data;
7b08b9eb
JK
6110
6111 return symbol_completion_match (name, data->text, data->text_len,
6112 data->wild_match, data->encoded) != NULL;
ccefe4c4
TT
6113}
6114
49c4e619
TT
6115/* Return a list of possible symbol names completing TEXT0. WORD is
6116 the entire command on which completion is made. */
41d27058 6117
49c4e619 6118static VEC (char_ptr) *
6f937416
PA
6119ada_make_symbol_completion_list (const char *text0, const char *word,
6120 enum type_code code)
41d27058
JB
6121{
6122 char *text;
6123 int text_len;
b1ed564a
JB
6124 int wild_match_p;
6125 int encoded_p;
2ba95b9b 6126 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
41d27058
JB
6127 struct symbol *sym;
6128 struct symtab *s;
41d27058
JB
6129 struct minimal_symbol *msymbol;
6130 struct objfile *objfile;
6131 struct block *b, *surrounding_static_block = 0;
6132 int i;
8157b174 6133 struct block_iterator iter;
b8fea896 6134 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
41d27058 6135
2f68a895
TT
6136 gdb_assert (code == TYPE_CODE_UNDEF);
6137
41d27058
JB
6138 if (text0[0] == '<')
6139 {
6140 text = xstrdup (text0);
6141 make_cleanup (xfree, text);
6142 text_len = strlen (text);
b1ed564a
JB
6143 wild_match_p = 0;
6144 encoded_p = 1;
41d27058
JB
6145 }
6146 else
6147 {
6148 text = xstrdup (ada_encode (text0));
6149 make_cleanup (xfree, text);
6150 text_len = strlen (text);
6151 for (i = 0; i < text_len; i++)
6152 text[i] = tolower (text[i]);
6153
b1ed564a 6154 encoded_p = (strstr (text0, "__") != NULL);
41d27058
JB
6155 /* If the name contains a ".", then the user is entering a fully
6156 qualified entity name, and the match must not be done in wild
6157 mode. Similarly, if the user wants to complete what looks like
6158 an encoded name, the match must not be done in wild mode. */
b1ed564a 6159 wild_match_p = (strchr (text0, '.') == NULL && !encoded_p);
41d27058
JB
6160 }
6161
6162 /* First, look at the partial symtab symbols. */
41d27058 6163 {
ccefe4c4
TT
6164 struct add_partial_datum data;
6165
6166 data.completions = &completions;
6167 data.text = text;
6168 data.text_len = text_len;
6169 data.text0 = text0;
6170 data.word = word;
b1ed564a
JB
6171 data.wild_match = wild_match_p;
6172 data.encoded = encoded_p;
bb4142cf
DE
6173 expand_symtabs_matching (NULL, ada_complete_symbol_matcher, ALL_DOMAIN,
6174 &data);
41d27058
JB
6175 }
6176
6177 /* At this point scan through the misc symbol vectors and add each
6178 symbol you find to the list. Eventually we want to ignore
6179 anything that isn't a text symbol (everything else will be
6180 handled by the psymtab code above). */
6181
6182 ALL_MSYMBOLS (objfile, msymbol)
6183 {
6184 QUIT;
efd66ac6 6185 symbol_completion_add (&completions, MSYMBOL_LINKAGE_NAME (msymbol),
b1ed564a
JB
6186 text, text_len, text0, word, wild_match_p,
6187 encoded_p);
41d27058
JB
6188 }
6189
6190 /* Search upwards from currently selected frame (so that we can
6191 complete on local vars. */
6192
6193 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6194 {
6195 if (!BLOCK_SUPERBLOCK (b))
6196 surrounding_static_block = b; /* For elmin of dups */
6197
6198 ALL_BLOCK_SYMBOLS (b, iter, sym)
6199 {
d6565258 6200 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6201 text, text_len, text0, word,
b1ed564a 6202 wild_match_p, encoded_p);
41d27058
JB
6203 }
6204 }
6205
6206 /* Go through the symtabs and check the externs and statics for
6207 symbols which match. */
6208
6209 ALL_SYMTABS (objfile, s)
6210 {
6211 QUIT;
6212 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
6213 ALL_BLOCK_SYMBOLS (b, iter, sym)
6214 {
d6565258 6215 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6216 text, text_len, text0, word,
b1ed564a 6217 wild_match_p, encoded_p);
41d27058
JB
6218 }
6219 }
6220
6221 ALL_SYMTABS (objfile, s)
6222 {
6223 QUIT;
6224 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
6225 /* Don't do this block twice. */
6226 if (b == surrounding_static_block)
6227 continue;
6228 ALL_BLOCK_SYMBOLS (b, iter, sym)
6229 {
d6565258 6230 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6231 text, text_len, text0, word,
b1ed564a 6232 wild_match_p, encoded_p);
41d27058
JB
6233 }
6234 }
6235
b8fea896 6236 do_cleanups (old_chain);
49c4e619 6237 return completions;
41d27058
JB
6238}
6239
963a6417 6240 /* Field Access */
96d887e8 6241
73fb9985
JB
6242/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6243 for tagged types. */
6244
6245static int
6246ada_is_dispatch_table_ptr_type (struct type *type)
6247{
0d5cff50 6248 const char *name;
73fb9985
JB
6249
6250 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6251 return 0;
6252
6253 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6254 if (name == NULL)
6255 return 0;
6256
6257 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6258}
6259
ac4a2da4
JG
6260/* Return non-zero if TYPE is an interface tag. */
6261
6262static int
6263ada_is_interface_tag (struct type *type)
6264{
6265 const char *name = TYPE_NAME (type);
6266
6267 if (name == NULL)
6268 return 0;
6269
6270 return (strcmp (name, "ada__tags__interface_tag") == 0);
6271}
6272
963a6417
PH
6273/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6274 to be invisible to users. */
96d887e8 6275
963a6417
PH
6276int
6277ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6278{
963a6417
PH
6279 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6280 return 1;
ffde82bf 6281
73fb9985
JB
6282 /* Check the name of that field. */
6283 {
6284 const char *name = TYPE_FIELD_NAME (type, field_num);
6285
6286 /* Anonymous field names should not be printed.
6287 brobecker/2007-02-20: I don't think this can actually happen
6288 but we don't want to print the value of annonymous fields anyway. */
6289 if (name == NULL)
6290 return 1;
6291
ffde82bf
JB
6292 /* Normally, fields whose name start with an underscore ("_")
6293 are fields that have been internally generated by the compiler,
6294 and thus should not be printed. The "_parent" field is special,
6295 however: This is a field internally generated by the compiler
6296 for tagged types, and it contains the components inherited from
6297 the parent type. This field should not be printed as is, but
6298 should not be ignored either. */
73fb9985
JB
6299 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
6300 return 1;
6301 }
6302
ac4a2da4
JG
6303 /* If this is the dispatch table of a tagged type or an interface tag,
6304 then ignore. */
73fb9985 6305 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6306 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6307 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6308 return 1;
6309
6310 /* Not a special field, so it should not be ignored. */
6311 return 0;
963a6417 6312}
96d887e8 6313
963a6417 6314/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6315 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6316
963a6417
PH
6317int
6318ada_is_tagged_type (struct type *type, int refok)
6319{
6320 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
6321}
96d887e8 6322
963a6417 6323/* True iff TYPE represents the type of X'Tag */
96d887e8 6324
963a6417
PH
6325int
6326ada_is_tag_type (struct type *type)
6327{
6328 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6329 return 0;
6330 else
96d887e8 6331 {
963a6417 6332 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6333
963a6417
PH
6334 return (name != NULL
6335 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6336 }
96d887e8
PH
6337}
6338
963a6417 6339/* The type of the tag on VAL. */
76a01679 6340
963a6417
PH
6341struct type *
6342ada_tag_type (struct value *val)
96d887e8 6343{
df407dfe 6344 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
963a6417 6345}
96d887e8 6346
b50d69b5
JG
6347/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6348 retired at Ada 05). */
6349
6350static int
6351is_ada95_tag (struct value *tag)
6352{
6353 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6354}
6355
963a6417 6356/* The value of the tag on VAL. */
96d887e8 6357
963a6417
PH
6358struct value *
6359ada_value_tag (struct value *val)
6360{
03ee6b2e 6361 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6362}
6363
963a6417
PH
6364/* The value of the tag on the object of type TYPE whose contents are
6365 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6366 ADDRESS. */
96d887e8 6367
963a6417 6368static struct value *
10a2c479 6369value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6370 const gdb_byte *valaddr,
963a6417 6371 CORE_ADDR address)
96d887e8 6372{
b5385fc0 6373 int tag_byte_offset;
963a6417 6374 struct type *tag_type;
5b4ee69b 6375
963a6417 6376 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6377 NULL, NULL, NULL))
96d887e8 6378 {
fc1a4b47 6379 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6380 ? NULL
6381 : valaddr + tag_byte_offset);
963a6417 6382 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6383
963a6417 6384 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6385 }
963a6417
PH
6386 return NULL;
6387}
96d887e8 6388
963a6417
PH
6389static struct type *
6390type_from_tag (struct value *tag)
6391{
6392 const char *type_name = ada_tag_name (tag);
5b4ee69b 6393
963a6417
PH
6394 if (type_name != NULL)
6395 return ada_find_any_type (ada_encode (type_name));
6396 return NULL;
6397}
96d887e8 6398
b50d69b5
JG
6399/* Given a value OBJ of a tagged type, return a value of this
6400 type at the base address of the object. The base address, as
6401 defined in Ada.Tags, it is the address of the primary tag of
6402 the object, and therefore where the field values of its full
6403 view can be fetched. */
6404
6405struct value *
6406ada_tag_value_at_base_address (struct value *obj)
6407{
6408 volatile struct gdb_exception e;
6409 struct value *val;
6410 LONGEST offset_to_top = 0;
6411 struct type *ptr_type, *obj_type;
6412 struct value *tag;
6413 CORE_ADDR base_address;
6414
6415 obj_type = value_type (obj);
6416
6417 /* It is the responsability of the caller to deref pointers. */
6418
6419 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6420 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6421 return obj;
6422
6423 tag = ada_value_tag (obj);
6424 if (!tag)
6425 return obj;
6426
6427 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6428
6429 if (is_ada95_tag (tag))
6430 return obj;
6431
6432 ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
6433 ptr_type = lookup_pointer_type (ptr_type);
6434 val = value_cast (ptr_type, tag);
6435 if (!val)
6436 return obj;
6437
6438 /* It is perfectly possible that an exception be raised while
6439 trying to determine the base address, just like for the tag;
6440 see ada_tag_name for more details. We do not print the error
6441 message for the same reason. */
6442
6443 TRY_CATCH (e, RETURN_MASK_ERROR)
6444 {
6445 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6446 }
6447
6448 if (e.reason < 0)
6449 return obj;
6450
6451 /* If offset is null, nothing to do. */
6452
6453 if (offset_to_top == 0)
6454 return obj;
6455
6456 /* -1 is a special case in Ada.Tags; however, what should be done
6457 is not quite clear from the documentation. So do nothing for
6458 now. */
6459
6460 if (offset_to_top == -1)
6461 return obj;
6462
6463 base_address = value_address (obj) - offset_to_top;
6464 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6465
6466 /* Make sure that we have a proper tag at the new address.
6467 Otherwise, offset_to_top is bogus (which can happen when
6468 the object is not initialized yet). */
6469
6470 if (!tag)
6471 return obj;
6472
6473 obj_type = type_from_tag (tag);
6474
6475 if (!obj_type)
6476 return obj;
6477
6478 return value_from_contents_and_address (obj_type, NULL, base_address);
6479}
6480
1b611343
JB
6481/* Return the "ada__tags__type_specific_data" type. */
6482
6483static struct type *
6484ada_get_tsd_type (struct inferior *inf)
963a6417 6485{
1b611343 6486 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6487
1b611343
JB
6488 if (data->tsd_type == 0)
6489 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6490 return data->tsd_type;
6491}
529cad9c 6492
1b611343
JB
6493/* Return the TSD (type-specific data) associated to the given TAG.
6494 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6495
1b611343 6496 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6497
1b611343
JB
6498static struct value *
6499ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6500{
4c4b4cd2 6501 struct value *val;
1b611343 6502 struct type *type;
5b4ee69b 6503
1b611343
JB
6504 /* First option: The TSD is simply stored as a field of our TAG.
6505 Only older versions of GNAT would use this format, but we have
6506 to test it first, because there are no visible markers for
6507 the current approach except the absence of that field. */
529cad9c 6508
1b611343
JB
6509 val = ada_value_struct_elt (tag, "tsd", 1);
6510 if (val)
6511 return val;
e802dbe0 6512
1b611343
JB
6513 /* Try the second representation for the dispatch table (in which
6514 there is no explicit 'tsd' field in the referent of the tag pointer,
6515 and instead the tsd pointer is stored just before the dispatch
6516 table. */
e802dbe0 6517
1b611343
JB
6518 type = ada_get_tsd_type (current_inferior());
6519 if (type == NULL)
6520 return NULL;
6521 type = lookup_pointer_type (lookup_pointer_type (type));
6522 val = value_cast (type, tag);
6523 if (val == NULL)
6524 return NULL;
6525 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6526}
6527
1b611343
JB
6528/* Given the TSD of a tag (type-specific data), return a string
6529 containing the name of the associated type.
6530
6531 The returned value is good until the next call. May return NULL
6532 if we are unable to determine the tag name. */
6533
6534static char *
6535ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6536{
529cad9c
PH
6537 static char name[1024];
6538 char *p;
1b611343 6539 struct value *val;
529cad9c 6540
1b611343 6541 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6542 if (val == NULL)
1b611343 6543 return NULL;
4c4b4cd2
PH
6544 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6545 for (p = name; *p != '\0'; p += 1)
6546 if (isalpha (*p))
6547 *p = tolower (*p);
1b611343 6548 return name;
4c4b4cd2
PH
6549}
6550
6551/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6552 a C string.
6553
6554 Return NULL if the TAG is not an Ada tag, or if we were unable to
6555 determine the name of that tag. The result is good until the next
6556 call. */
4c4b4cd2
PH
6557
6558const char *
6559ada_tag_name (struct value *tag)
6560{
1b611343
JB
6561 volatile struct gdb_exception e;
6562 char *name = NULL;
5b4ee69b 6563
df407dfe 6564 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6565 return NULL;
1b611343
JB
6566
6567 /* It is perfectly possible that an exception be raised while trying
6568 to determine the TAG's name, even under normal circumstances:
6569 The associated variable may be uninitialized or corrupted, for
6570 instance. We do not let any exception propagate past this point.
6571 instead we return NULL.
6572
6573 We also do not print the error message either (which often is very
6574 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6575 the caller print a more meaningful message if necessary. */
6576 TRY_CATCH (e, RETURN_MASK_ERROR)
6577 {
6578 struct value *tsd = ada_get_tsd_from_tag (tag);
6579
6580 if (tsd != NULL)
6581 name = ada_tag_name_from_tsd (tsd);
6582 }
6583
6584 return name;
4c4b4cd2
PH
6585}
6586
6587/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6588
d2e4a39e 6589struct type *
ebf56fd3 6590ada_parent_type (struct type *type)
14f9c5c9
AS
6591{
6592 int i;
6593
61ee279c 6594 type = ada_check_typedef (type);
14f9c5c9
AS
6595
6596 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6597 return NULL;
6598
6599 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6600 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6601 {
6602 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6603
6604 /* If the _parent field is a pointer, then dereference it. */
6605 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6606 parent_type = TYPE_TARGET_TYPE (parent_type);
6607 /* If there is a parallel XVS type, get the actual base type. */
6608 parent_type = ada_get_base_type (parent_type);
6609
6610 return ada_check_typedef (parent_type);
6611 }
14f9c5c9
AS
6612
6613 return NULL;
6614}
6615
4c4b4cd2
PH
6616/* True iff field number FIELD_NUM of structure type TYPE contains the
6617 parent-type (inherited) fields of a derived type. Assumes TYPE is
6618 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6619
6620int
ebf56fd3 6621ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6622{
61ee279c 6623 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6624
4c4b4cd2
PH
6625 return (name != NULL
6626 && (strncmp (name, "PARENT", 6) == 0
6627 || strncmp (name, "_parent", 7) == 0));
14f9c5c9
AS
6628}
6629
4c4b4cd2 6630/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6631 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6632 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6633 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6634 structures. */
14f9c5c9
AS
6635
6636int
ebf56fd3 6637ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6638{
d2e4a39e 6639 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6640
d2e4a39e 6641 return (name != NULL
4c4b4cd2
PH
6642 && (strncmp (name, "PARENT", 6) == 0
6643 || strcmp (name, "REP") == 0
6644 || strncmp (name, "_parent", 7) == 0
6645 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6646}
6647
4c4b4cd2
PH
6648/* True iff field number FIELD_NUM of structure or union type TYPE
6649 is a variant wrapper. Assumes TYPE is a structure type with at least
6650 FIELD_NUM+1 fields. */
14f9c5c9
AS
6651
6652int
ebf56fd3 6653ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6654{
d2e4a39e 6655 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6656
14f9c5c9 6657 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6658 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6659 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6660 == TYPE_CODE_UNION)));
14f9c5c9
AS
6661}
6662
6663/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6664 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6665 returns the type of the controlling discriminant for the variant.
6666 May return NULL if the type could not be found. */
14f9c5c9 6667
d2e4a39e 6668struct type *
ebf56fd3 6669ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6670{
d2e4a39e 6671 char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6672
7c964f07 6673 return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
14f9c5c9
AS
6674}
6675
4c4b4cd2 6676/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6677 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6678 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6679
6680int
ebf56fd3 6681ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6682{
d2e4a39e 6683 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6684
14f9c5c9
AS
6685 return (name != NULL && name[0] == 'O');
6686}
6687
6688/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
6689 returns the name of the discriminant controlling the variant.
6690 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 6691
d2e4a39e 6692char *
ebf56fd3 6693ada_variant_discrim_name (struct type *type0)
14f9c5c9 6694{
d2e4a39e 6695 static char *result = NULL;
14f9c5c9 6696 static size_t result_len = 0;
d2e4a39e
AS
6697 struct type *type;
6698 const char *name;
6699 const char *discrim_end;
6700 const char *discrim_start;
14f9c5c9
AS
6701
6702 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6703 type = TYPE_TARGET_TYPE (type0);
6704 else
6705 type = type0;
6706
6707 name = ada_type_name (type);
6708
6709 if (name == NULL || name[0] == '\000')
6710 return "";
6711
6712 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6713 discrim_end -= 1)
6714 {
4c4b4cd2
PH
6715 if (strncmp (discrim_end, "___XVN", 6) == 0)
6716 break;
14f9c5c9
AS
6717 }
6718 if (discrim_end == name)
6719 return "";
6720
d2e4a39e 6721 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
6722 discrim_start -= 1)
6723 {
d2e4a39e 6724 if (discrim_start == name + 1)
4c4b4cd2 6725 return "";
76a01679 6726 if ((discrim_start > name + 3
4c4b4cd2
PH
6727 && strncmp (discrim_start - 3, "___", 3) == 0)
6728 || discrim_start[-1] == '.')
6729 break;
14f9c5c9
AS
6730 }
6731
6732 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6733 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 6734 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
6735 return result;
6736}
6737
4c4b4cd2
PH
6738/* Scan STR for a subtype-encoded number, beginning at position K.
6739 Put the position of the character just past the number scanned in
6740 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6741 Return 1 if there was a valid number at the given position, and 0
6742 otherwise. A "subtype-encoded" number consists of the absolute value
6743 in decimal, followed by the letter 'm' to indicate a negative number.
6744 Assumes 0m does not occur. */
14f9c5c9
AS
6745
6746int
d2e4a39e 6747ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
6748{
6749 ULONGEST RU;
6750
d2e4a39e 6751 if (!isdigit (str[k]))
14f9c5c9
AS
6752 return 0;
6753
4c4b4cd2 6754 /* Do it the hard way so as not to make any assumption about
14f9c5c9 6755 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 6756 LONGEST. */
14f9c5c9
AS
6757 RU = 0;
6758 while (isdigit (str[k]))
6759 {
d2e4a39e 6760 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
6761 k += 1;
6762 }
6763
d2e4a39e 6764 if (str[k] == 'm')
14f9c5c9
AS
6765 {
6766 if (R != NULL)
4c4b4cd2 6767 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
6768 k += 1;
6769 }
6770 else if (R != NULL)
6771 *R = (LONGEST) RU;
6772
4c4b4cd2 6773 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
6774 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6775 number representable as a LONGEST (although either would probably work
6776 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 6777 above is always equivalent to the negative of RU. */
14f9c5c9
AS
6778
6779 if (new_k != NULL)
6780 *new_k = k;
6781 return 1;
6782}
6783
4c4b4cd2
PH
6784/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6785 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6786 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 6787
d2e4a39e 6788int
ebf56fd3 6789ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 6790{
d2e4a39e 6791 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
6792 int p;
6793
6794 p = 0;
6795 while (1)
6796 {
d2e4a39e 6797 switch (name[p])
4c4b4cd2
PH
6798 {
6799 case '\0':
6800 return 0;
6801 case 'S':
6802 {
6803 LONGEST W;
5b4ee69b 6804
4c4b4cd2
PH
6805 if (!ada_scan_number (name, p + 1, &W, &p))
6806 return 0;
6807 if (val == W)
6808 return 1;
6809 break;
6810 }
6811 case 'R':
6812 {
6813 LONGEST L, U;
5b4ee69b 6814
4c4b4cd2
PH
6815 if (!ada_scan_number (name, p + 1, &L, &p)
6816 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6817 return 0;
6818 if (val >= L && val <= U)
6819 return 1;
6820 break;
6821 }
6822 case 'O':
6823 return 1;
6824 default:
6825 return 0;
6826 }
6827 }
6828}
6829
0963b4bd 6830/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
6831
6832/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6833 ARG_TYPE, extract and return the value of one of its (non-static)
6834 fields. FIELDNO says which field. Differs from value_primitive_field
6835 only in that it can handle packed values of arbitrary type. */
14f9c5c9 6836
4c4b4cd2 6837static struct value *
d2e4a39e 6838ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 6839 struct type *arg_type)
14f9c5c9 6840{
14f9c5c9
AS
6841 struct type *type;
6842
61ee279c 6843 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
6844 type = TYPE_FIELD_TYPE (arg_type, fieldno);
6845
4c4b4cd2 6846 /* Handle packed fields. */
14f9c5c9
AS
6847
6848 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
6849 {
6850 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6851 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 6852
0fd88904 6853 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
6854 offset + bit_pos / 8,
6855 bit_pos % 8, bit_size, type);
14f9c5c9
AS
6856 }
6857 else
6858 return value_primitive_field (arg1, offset, fieldno, arg_type);
6859}
6860
52ce6436
PH
6861/* Find field with name NAME in object of type TYPE. If found,
6862 set the following for each argument that is non-null:
6863 - *FIELD_TYPE_P to the field's type;
6864 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6865 an object of that type;
6866 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6867 - *BIT_SIZE_P to its size in bits if the field is packed, and
6868 0 otherwise;
6869 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6870 fields up to but not including the desired field, or by the total
6871 number of fields if not found. A NULL value of NAME never
6872 matches; the function just counts visible fields in this case.
6873
0963b4bd 6874 Returns 1 if found, 0 otherwise. */
52ce6436 6875
4c4b4cd2 6876static int
0d5cff50 6877find_struct_field (const char *name, struct type *type, int offset,
76a01679 6878 struct type **field_type_p,
52ce6436
PH
6879 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6880 int *index_p)
4c4b4cd2
PH
6881{
6882 int i;
6883
61ee279c 6884 type = ada_check_typedef (type);
76a01679 6885
52ce6436
PH
6886 if (field_type_p != NULL)
6887 *field_type_p = NULL;
6888 if (byte_offset_p != NULL)
d5d6fca5 6889 *byte_offset_p = 0;
52ce6436
PH
6890 if (bit_offset_p != NULL)
6891 *bit_offset_p = 0;
6892 if (bit_size_p != NULL)
6893 *bit_size_p = 0;
6894
6895 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
6896 {
6897 int bit_pos = TYPE_FIELD_BITPOS (type, i);
6898 int fld_offset = offset + bit_pos / 8;
0d5cff50 6899 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 6900
4c4b4cd2
PH
6901 if (t_field_name == NULL)
6902 continue;
6903
52ce6436 6904 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
6905 {
6906 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 6907
52ce6436
PH
6908 if (field_type_p != NULL)
6909 *field_type_p = TYPE_FIELD_TYPE (type, i);
6910 if (byte_offset_p != NULL)
6911 *byte_offset_p = fld_offset;
6912 if (bit_offset_p != NULL)
6913 *bit_offset_p = bit_pos % 8;
6914 if (bit_size_p != NULL)
6915 *bit_size_p = bit_size;
76a01679
JB
6916 return 1;
6917 }
4c4b4cd2
PH
6918 else if (ada_is_wrapper_field (type, i))
6919 {
52ce6436
PH
6920 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
6921 field_type_p, byte_offset_p, bit_offset_p,
6922 bit_size_p, index_p))
76a01679
JB
6923 return 1;
6924 }
4c4b4cd2
PH
6925 else if (ada_is_variant_part (type, i))
6926 {
52ce6436
PH
6927 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6928 fixed type?? */
4c4b4cd2 6929 int j;
52ce6436
PH
6930 struct type *field_type
6931 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 6932
52ce6436 6933 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6934 {
76a01679
JB
6935 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
6936 fld_offset
6937 + TYPE_FIELD_BITPOS (field_type, j) / 8,
6938 field_type_p, byte_offset_p,
52ce6436 6939 bit_offset_p, bit_size_p, index_p))
76a01679 6940 return 1;
4c4b4cd2
PH
6941 }
6942 }
52ce6436
PH
6943 else if (index_p != NULL)
6944 *index_p += 1;
4c4b4cd2
PH
6945 }
6946 return 0;
6947}
6948
0963b4bd 6949/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 6950
52ce6436
PH
6951static int
6952num_visible_fields (struct type *type)
6953{
6954 int n;
5b4ee69b 6955
52ce6436
PH
6956 n = 0;
6957 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6958 return n;
6959}
14f9c5c9 6960
4c4b4cd2 6961/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
6962 and search in it assuming it has (class) type TYPE.
6963 If found, return value, else return NULL.
6964
4c4b4cd2 6965 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 6966
4c4b4cd2 6967static struct value *
d2e4a39e 6968ada_search_struct_field (char *name, struct value *arg, int offset,
4c4b4cd2 6969 struct type *type)
14f9c5c9
AS
6970{
6971 int i;
14f9c5c9 6972
5b4ee69b 6973 type = ada_check_typedef (type);
52ce6436 6974 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 6975 {
0d5cff50 6976 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
6977
6978 if (t_field_name == NULL)
4c4b4cd2 6979 continue;
14f9c5c9
AS
6980
6981 else if (field_name_match (t_field_name, name))
4c4b4cd2 6982 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
6983
6984 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 6985 {
0963b4bd 6986 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
6987 ada_search_struct_field (name, arg,
6988 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6989 TYPE_FIELD_TYPE (type, i));
5b4ee69b 6990
4c4b4cd2
PH
6991 if (v != NULL)
6992 return v;
6993 }
14f9c5c9
AS
6994
6995 else if (ada_is_variant_part (type, i))
4c4b4cd2 6996 {
0963b4bd 6997 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 6998 int j;
5b4ee69b
MS
6999 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7000 i));
4c4b4cd2
PH
7001 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7002
52ce6436 7003 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7004 {
0963b4bd
MS
7005 struct value *v = ada_search_struct_field /* Force line
7006 break. */
06d5cf63
JB
7007 (name, arg,
7008 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7009 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 7010
4c4b4cd2
PH
7011 if (v != NULL)
7012 return v;
7013 }
7014 }
14f9c5c9
AS
7015 }
7016 return NULL;
7017}
d2e4a39e 7018
52ce6436
PH
7019static struct value *ada_index_struct_field_1 (int *, struct value *,
7020 int, struct type *);
7021
7022
7023/* Return field #INDEX in ARG, where the index is that returned by
7024 * find_struct_field through its INDEX_P argument. Adjust the address
7025 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 7026 * If found, return value, else return NULL. */
52ce6436
PH
7027
7028static struct value *
7029ada_index_struct_field (int index, struct value *arg, int offset,
7030 struct type *type)
7031{
7032 return ada_index_struct_field_1 (&index, arg, offset, type);
7033}
7034
7035
7036/* Auxiliary function for ada_index_struct_field. Like
7037 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 7038 * *INDEX_P. */
52ce6436
PH
7039
7040static struct value *
7041ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7042 struct type *type)
7043{
7044 int i;
7045 type = ada_check_typedef (type);
7046
7047 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7048 {
7049 if (TYPE_FIELD_NAME (type, i) == NULL)
7050 continue;
7051 else if (ada_is_wrapper_field (type, i))
7052 {
0963b4bd 7053 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
7054 ada_index_struct_field_1 (index_p, arg,
7055 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7056 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7057
52ce6436
PH
7058 if (v != NULL)
7059 return v;
7060 }
7061
7062 else if (ada_is_variant_part (type, i))
7063 {
7064 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 7065 find_struct_field. */
52ce6436
PH
7066 error (_("Cannot assign this kind of variant record"));
7067 }
7068 else if (*index_p == 0)
7069 return ada_value_primitive_field (arg, offset, i, type);
7070 else
7071 *index_p -= 1;
7072 }
7073 return NULL;
7074}
7075
4c4b4cd2
PH
7076/* Given ARG, a value of type (pointer or reference to a)*
7077 structure/union, extract the component named NAME from the ultimate
7078 target structure/union and return it as a value with its
f5938064 7079 appropriate type.
14f9c5c9 7080
4c4b4cd2
PH
7081 The routine searches for NAME among all members of the structure itself
7082 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7083 (e.g., '_parent').
7084
03ee6b2e
PH
7085 If NO_ERR, then simply return NULL in case of error, rather than
7086 calling error. */
14f9c5c9 7087
d2e4a39e 7088struct value *
03ee6b2e 7089ada_value_struct_elt (struct value *arg, char *name, int no_err)
14f9c5c9 7090{
4c4b4cd2 7091 struct type *t, *t1;
d2e4a39e 7092 struct value *v;
14f9c5c9 7093
4c4b4cd2 7094 v = NULL;
df407dfe 7095 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
7096 if (TYPE_CODE (t) == TYPE_CODE_REF)
7097 {
7098 t1 = TYPE_TARGET_TYPE (t);
7099 if (t1 == NULL)
03ee6b2e 7100 goto BadValue;
61ee279c 7101 t1 = ada_check_typedef (t1);
4c4b4cd2 7102 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 7103 {
994b9211 7104 arg = coerce_ref (arg);
76a01679
JB
7105 t = t1;
7106 }
4c4b4cd2 7107 }
14f9c5c9 7108
4c4b4cd2
PH
7109 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7110 {
7111 t1 = TYPE_TARGET_TYPE (t);
7112 if (t1 == NULL)
03ee6b2e 7113 goto BadValue;
61ee279c 7114 t1 = ada_check_typedef (t1);
4c4b4cd2 7115 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7116 {
7117 arg = value_ind (arg);
7118 t = t1;
7119 }
4c4b4cd2 7120 else
76a01679 7121 break;
4c4b4cd2 7122 }
14f9c5c9 7123
4c4b4cd2 7124 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 7125 goto BadValue;
14f9c5c9 7126
4c4b4cd2
PH
7127 if (t1 == t)
7128 v = ada_search_struct_field (name, arg, 0, t);
7129 else
7130 {
7131 int bit_offset, bit_size, byte_offset;
7132 struct type *field_type;
7133 CORE_ADDR address;
7134
76a01679 7135 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 7136 address = value_address (ada_value_ind (arg));
4c4b4cd2 7137 else
b50d69b5 7138 address = value_address (ada_coerce_ref (arg));
14f9c5c9 7139
1ed6ede0 7140 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
76a01679
JB
7141 if (find_struct_field (name, t1, 0,
7142 &field_type, &byte_offset, &bit_offset,
52ce6436 7143 &bit_size, NULL))
76a01679
JB
7144 {
7145 if (bit_size != 0)
7146 {
714e53ab
PH
7147 if (TYPE_CODE (t) == TYPE_CODE_REF)
7148 arg = ada_coerce_ref (arg);
7149 else
7150 arg = ada_value_ind (arg);
76a01679
JB
7151 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7152 bit_offset, bit_size,
7153 field_type);
7154 }
7155 else
f5938064 7156 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
7157 }
7158 }
7159
03ee6b2e
PH
7160 if (v != NULL || no_err)
7161 return v;
7162 else
323e0a4a 7163 error (_("There is no member named %s."), name);
14f9c5c9 7164
03ee6b2e
PH
7165 BadValue:
7166 if (no_err)
7167 return NULL;
7168 else
0963b4bd
MS
7169 error (_("Attempt to extract a component of "
7170 "a value that is not a record."));
14f9c5c9
AS
7171}
7172
7173/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7174 If DISPP is non-null, add its byte displacement from the beginning of a
7175 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7176 work for packed fields).
7177
7178 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7179 followed by "___".
14f9c5c9 7180
0963b4bd 7181 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
7182 be a (pointer or reference)+ to a struct or union, and the
7183 ultimate target type will be searched.
14f9c5c9
AS
7184
7185 Looks recursively into variant clauses and parent types.
7186
4c4b4cd2
PH
7187 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7188 TYPE is not a type of the right kind. */
14f9c5c9 7189
4c4b4cd2 7190static struct type *
76a01679
JB
7191ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
7192 int noerr, int *dispp)
14f9c5c9
AS
7193{
7194 int i;
7195
7196 if (name == NULL)
7197 goto BadName;
7198
76a01679 7199 if (refok && type != NULL)
4c4b4cd2
PH
7200 while (1)
7201 {
61ee279c 7202 type = ada_check_typedef (type);
76a01679
JB
7203 if (TYPE_CODE (type) != TYPE_CODE_PTR
7204 && TYPE_CODE (type) != TYPE_CODE_REF)
7205 break;
7206 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7207 }
14f9c5c9 7208
76a01679 7209 if (type == NULL
1265e4aa
JB
7210 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7211 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7212 {
4c4b4cd2 7213 if (noerr)
76a01679 7214 return NULL;
4c4b4cd2 7215 else
76a01679
JB
7216 {
7217 target_terminal_ours ();
7218 gdb_flush (gdb_stdout);
323e0a4a
AC
7219 if (type == NULL)
7220 error (_("Type (null) is not a structure or union type"));
7221 else
7222 {
7223 /* XXX: type_sprint */
7224 fprintf_unfiltered (gdb_stderr, _("Type "));
7225 type_print (type, "", gdb_stderr, -1);
7226 error (_(" is not a structure or union type"));
7227 }
76a01679 7228 }
14f9c5c9
AS
7229 }
7230
7231 type = to_static_fixed_type (type);
7232
7233 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7234 {
0d5cff50 7235 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7236 struct type *t;
7237 int disp;
d2e4a39e 7238
14f9c5c9 7239 if (t_field_name == NULL)
4c4b4cd2 7240 continue;
14f9c5c9
AS
7241
7242 else if (field_name_match (t_field_name, name))
4c4b4cd2
PH
7243 {
7244 if (dispp != NULL)
7245 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
61ee279c 7246 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7247 }
14f9c5c9
AS
7248
7249 else if (ada_is_wrapper_field (type, i))
4c4b4cd2
PH
7250 {
7251 disp = 0;
7252 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7253 0, 1, &disp);
7254 if (t != NULL)
7255 {
7256 if (dispp != NULL)
7257 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7258 return t;
7259 }
7260 }
14f9c5c9
AS
7261
7262 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7263 {
7264 int j;
5b4ee69b
MS
7265 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7266 i));
4c4b4cd2
PH
7267
7268 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7269 {
b1f33ddd
JB
7270 /* FIXME pnh 2008/01/26: We check for a field that is
7271 NOT wrapped in a struct, since the compiler sometimes
7272 generates these for unchecked variant types. Revisit
0963b4bd 7273 if the compiler changes this practice. */
0d5cff50 7274 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
4c4b4cd2 7275 disp = 0;
b1f33ddd
JB
7276 if (v_field_name != NULL
7277 && field_name_match (v_field_name, name))
7278 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
7279 else
0963b4bd
MS
7280 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7281 j),
b1f33ddd
JB
7282 name, 0, 1, &disp);
7283
4c4b4cd2
PH
7284 if (t != NULL)
7285 {
7286 if (dispp != NULL)
7287 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7288 return t;
7289 }
7290 }
7291 }
14f9c5c9
AS
7292
7293 }
7294
7295BadName:
d2e4a39e 7296 if (!noerr)
14f9c5c9
AS
7297 {
7298 target_terminal_ours ();
7299 gdb_flush (gdb_stdout);
323e0a4a
AC
7300 if (name == NULL)
7301 {
7302 /* XXX: type_sprint */
7303 fprintf_unfiltered (gdb_stderr, _("Type "));
7304 type_print (type, "", gdb_stderr, -1);
7305 error (_(" has no component named <null>"));
7306 }
7307 else
7308 {
7309 /* XXX: type_sprint */
7310 fprintf_unfiltered (gdb_stderr, _("Type "));
7311 type_print (type, "", gdb_stderr, -1);
7312 error (_(" has no component named %s"), name);
7313 }
14f9c5c9
AS
7314 }
7315
7316 return NULL;
7317}
7318
b1f33ddd
JB
7319/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7320 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7321 represents an unchecked union (that is, the variant part of a
0963b4bd 7322 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7323
7324static int
7325is_unchecked_variant (struct type *var_type, struct type *outer_type)
7326{
7327 char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7328
b1f33ddd
JB
7329 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
7330 == NULL);
7331}
7332
7333
14f9c5c9
AS
7334/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7335 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7336 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7337 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7338
d2e4a39e 7339int
ebf56fd3 7340ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7341 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7342{
7343 int others_clause;
7344 int i;
d2e4a39e 7345 char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7346 struct value *outer;
7347 struct value *discrim;
14f9c5c9
AS
7348 LONGEST discrim_val;
7349
0c281816
JB
7350 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
7351 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7352 if (discrim == NULL)
14f9c5c9 7353 return -1;
0c281816 7354 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7355
7356 others_clause = -1;
7357 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7358 {
7359 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7360 others_clause = i;
14f9c5c9 7361 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7362 return i;
14f9c5c9
AS
7363 }
7364
7365 return others_clause;
7366}
d2e4a39e 7367\f
14f9c5c9
AS
7368
7369
4c4b4cd2 7370 /* Dynamic-Sized Records */
14f9c5c9
AS
7371
7372/* Strategy: The type ostensibly attached to a value with dynamic size
7373 (i.e., a size that is not statically recorded in the debugging
7374 data) does not accurately reflect the size or layout of the value.
7375 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7376 conventional types that are constructed on the fly. */
14f9c5c9
AS
7377
7378/* There is a subtle and tricky problem here. In general, we cannot
7379 determine the size of dynamic records without its data. However,
7380 the 'struct value' data structure, which GDB uses to represent
7381 quantities in the inferior process (the target), requires the size
7382 of the type at the time of its allocation in order to reserve space
7383 for GDB's internal copy of the data. That's why the
7384 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7385 rather than struct value*s.
14f9c5c9
AS
7386
7387 However, GDB's internal history variables ($1, $2, etc.) are
7388 struct value*s containing internal copies of the data that are not, in
7389 general, the same as the data at their corresponding addresses in
7390 the target. Fortunately, the types we give to these values are all
7391 conventional, fixed-size types (as per the strategy described
7392 above), so that we don't usually have to perform the
7393 'to_fixed_xxx_type' conversions to look at their values.
7394 Unfortunately, there is one exception: if one of the internal
7395 history variables is an array whose elements are unconstrained
7396 records, then we will need to create distinct fixed types for each
7397 element selected. */
7398
7399/* The upshot of all of this is that many routines take a (type, host
7400 address, target address) triple as arguments to represent a value.
7401 The host address, if non-null, is supposed to contain an internal
7402 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7403 target at the target address. */
14f9c5c9
AS
7404
7405/* Assuming that VAL0 represents a pointer value, the result of
7406 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7407 dynamic-sized types. */
14f9c5c9 7408
d2e4a39e
AS
7409struct value *
7410ada_value_ind (struct value *val0)
14f9c5c9 7411{
c48db5ca 7412 struct value *val = value_ind (val0);
5b4ee69b 7413
b50d69b5
JG
7414 if (ada_is_tagged_type (value_type (val), 0))
7415 val = ada_tag_value_at_base_address (val);
7416
4c4b4cd2 7417 return ada_to_fixed_value (val);
14f9c5c9
AS
7418}
7419
7420/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7421 qualifiers on VAL0. */
7422
d2e4a39e
AS
7423static struct value *
7424ada_coerce_ref (struct value *val0)
7425{
df407dfe 7426 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7427 {
7428 struct value *val = val0;
5b4ee69b 7429
994b9211 7430 val = coerce_ref (val);
b50d69b5
JG
7431
7432 if (ada_is_tagged_type (value_type (val), 0))
7433 val = ada_tag_value_at_base_address (val);
7434
4c4b4cd2 7435 return ada_to_fixed_value (val);
d2e4a39e
AS
7436 }
7437 else
14f9c5c9
AS
7438 return val0;
7439}
7440
7441/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7442 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7443
7444static unsigned int
ebf56fd3 7445align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7446{
7447 return (off + alignment - 1) & ~(alignment - 1);
7448}
7449
4c4b4cd2 7450/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7451
7452static unsigned int
ebf56fd3 7453field_alignment (struct type *type, int f)
14f9c5c9 7454{
d2e4a39e 7455 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7456 int len;
14f9c5c9
AS
7457 int align_offset;
7458
64a1bf19
JB
7459 /* The field name should never be null, unless the debugging information
7460 is somehow malformed. In this case, we assume the field does not
7461 require any alignment. */
7462 if (name == NULL)
7463 return 1;
7464
7465 len = strlen (name);
7466
4c4b4cd2
PH
7467 if (!isdigit (name[len - 1]))
7468 return 1;
14f9c5c9 7469
d2e4a39e 7470 if (isdigit (name[len - 2]))
14f9c5c9
AS
7471 align_offset = len - 2;
7472 else
7473 align_offset = len - 1;
7474
4c4b4cd2 7475 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
14f9c5c9
AS
7476 return TARGET_CHAR_BIT;
7477
4c4b4cd2
PH
7478 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7479}
7480
852dff6c 7481/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7482
852dff6c
JB
7483static struct symbol *
7484ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7485{
7486 struct symbol *sym;
7487
7488 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7489 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7490 return sym;
7491
7492 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7493 return sym;
14f9c5c9
AS
7494}
7495
dddfab26
UW
7496/* Find a type named NAME. Ignores ambiguity. This routine will look
7497 solely for types defined by debug info, it will not search the GDB
7498 primitive types. */
4c4b4cd2 7499
852dff6c 7500static struct type *
ebf56fd3 7501ada_find_any_type (const char *name)
14f9c5c9 7502{
852dff6c 7503 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7504
14f9c5c9 7505 if (sym != NULL)
dddfab26 7506 return SYMBOL_TYPE (sym);
14f9c5c9 7507
dddfab26 7508 return NULL;
14f9c5c9
AS
7509}
7510
739593e0
JB
7511/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7512 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7513 symbol, in which case it is returned. Otherwise, this looks for
7514 symbols whose name is that of NAME_SYM suffixed with "___XR".
7515 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7516
7517struct symbol *
270140bd 7518ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7519{
739593e0 7520 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7521 struct symbol *sym;
7522
739593e0
JB
7523 if (strstr (name, "___XR") != NULL)
7524 return name_sym;
7525
aeb5907d
JB
7526 sym = find_old_style_renaming_symbol (name, block);
7527
7528 if (sym != NULL)
7529 return sym;
7530
0963b4bd 7531 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7532 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7533 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7534 return sym;
7535 else
7536 return NULL;
7537}
7538
7539static struct symbol *
270140bd 7540find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 7541{
7f0df278 7542 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
7543 char *rename;
7544
7545 if (function_sym != NULL)
7546 {
7547 /* If the symbol is defined inside a function, NAME is not fully
7548 qualified. This means we need to prepend the function name
7549 as well as adding the ``___XR'' suffix to build the name of
7550 the associated renaming symbol. */
0d5cff50 7551 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
7552 /* Function names sometimes contain suffixes used
7553 for instance to qualify nested subprograms. When building
7554 the XR type name, we need to make sure that this suffix is
7555 not included. So do not include any suffix in the function
7556 name length below. */
69fadcdf 7557 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
7558 const int rename_len = function_name_len + 2 /* "__" */
7559 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 7560
529cad9c 7561 /* Strip the suffix if necessary. */
69fadcdf
JB
7562 ada_remove_trailing_digits (function_name, &function_name_len);
7563 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7564 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 7565
4c4b4cd2
PH
7566 /* Library-level functions are a special case, as GNAT adds
7567 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 7568 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
7569 have this prefix, so we need to skip this prefix if present. */
7570 if (function_name_len > 5 /* "_ada_" */
7571 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
7572 {
7573 function_name += 5;
7574 function_name_len -= 5;
7575 }
4c4b4cd2
PH
7576
7577 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
7578 strncpy (rename, function_name, function_name_len);
7579 xsnprintf (rename + function_name_len, rename_len - function_name_len,
7580 "__%s___XR", name);
4c4b4cd2
PH
7581 }
7582 else
7583 {
7584 const int rename_len = strlen (name) + 6;
5b4ee69b 7585
4c4b4cd2 7586 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 7587 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
7588 }
7589
852dff6c 7590 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
7591}
7592
14f9c5c9 7593/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 7594 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 7595 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
7596 otherwise return 0. */
7597
14f9c5c9 7598int
d2e4a39e 7599ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
7600{
7601 if (type1 == NULL)
7602 return 1;
7603 else if (type0 == NULL)
7604 return 0;
7605 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7606 return 1;
7607 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7608 return 0;
4c4b4cd2
PH
7609 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7610 return 1;
ad82864c 7611 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 7612 return 1;
4c4b4cd2
PH
7613 else if (ada_is_array_descriptor_type (type0)
7614 && !ada_is_array_descriptor_type (type1))
14f9c5c9 7615 return 1;
aeb5907d
JB
7616 else
7617 {
7618 const char *type0_name = type_name_no_tag (type0);
7619 const char *type1_name = type_name_no_tag (type1);
7620
7621 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7622 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7623 return 1;
7624 }
14f9c5c9
AS
7625 return 0;
7626}
7627
7628/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
7629 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7630
0d5cff50 7631const char *
d2e4a39e 7632ada_type_name (struct type *type)
14f9c5c9 7633{
d2e4a39e 7634 if (type == NULL)
14f9c5c9
AS
7635 return NULL;
7636 else if (TYPE_NAME (type) != NULL)
7637 return TYPE_NAME (type);
7638 else
7639 return TYPE_TAG_NAME (type);
7640}
7641
b4ba55a1
JB
7642/* Search the list of "descriptive" types associated to TYPE for a type
7643 whose name is NAME. */
7644
7645static struct type *
7646find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7647{
7648 struct type *result;
7649
c6044dd1
JB
7650 if (ada_ignore_descriptive_types_p)
7651 return NULL;
7652
b4ba55a1
JB
7653 /* If there no descriptive-type info, then there is no parallel type
7654 to be found. */
7655 if (!HAVE_GNAT_AUX_INFO (type))
7656 return NULL;
7657
7658 result = TYPE_DESCRIPTIVE_TYPE (type);
7659 while (result != NULL)
7660 {
0d5cff50 7661 const char *result_name = ada_type_name (result);
b4ba55a1
JB
7662
7663 if (result_name == NULL)
7664 {
7665 warning (_("unexpected null name on descriptive type"));
7666 return NULL;
7667 }
7668
7669 /* If the names match, stop. */
7670 if (strcmp (result_name, name) == 0)
7671 break;
7672
7673 /* Otherwise, look at the next item on the list, if any. */
7674 if (HAVE_GNAT_AUX_INFO (result))
7675 result = TYPE_DESCRIPTIVE_TYPE (result);
7676 else
7677 result = NULL;
7678 }
7679
7680 /* If we didn't find a match, see whether this is a packed array. With
7681 older compilers, the descriptive type information is either absent or
7682 irrelevant when it comes to packed arrays so the above lookup fails.
7683 Fall back to using a parallel lookup by name in this case. */
12ab9e09 7684 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
7685 return ada_find_any_type (name);
7686
7687 return result;
7688}
7689
7690/* Find a parallel type to TYPE with the specified NAME, using the
7691 descriptive type taken from the debugging information, if available,
7692 and otherwise using the (slower) name-based method. */
7693
7694static struct type *
7695ada_find_parallel_type_with_name (struct type *type, const char *name)
7696{
7697 struct type *result = NULL;
7698
7699 if (HAVE_GNAT_AUX_INFO (type))
7700 result = find_parallel_type_by_descriptive_type (type, name);
7701 else
7702 result = ada_find_any_type (name);
7703
7704 return result;
7705}
7706
7707/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 7708 SUFFIX to the name of TYPE. */
14f9c5c9 7709
d2e4a39e 7710struct type *
ebf56fd3 7711ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 7712{
0d5cff50
DE
7713 char *name;
7714 const char *typename = ada_type_name (type);
14f9c5c9 7715 int len;
d2e4a39e 7716
14f9c5c9
AS
7717 if (typename == NULL)
7718 return NULL;
7719
7720 len = strlen (typename);
7721
b4ba55a1 7722 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9
AS
7723
7724 strcpy (name, typename);
7725 strcpy (name + len, suffix);
7726
b4ba55a1 7727 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
7728}
7729
14f9c5c9 7730/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 7731 type describing its fields. Otherwise, return NULL. */
14f9c5c9 7732
d2e4a39e
AS
7733static struct type *
7734dynamic_template_type (struct type *type)
14f9c5c9 7735{
61ee279c 7736 type = ada_check_typedef (type);
14f9c5c9
AS
7737
7738 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 7739 || ada_type_name (type) == NULL)
14f9c5c9 7740 return NULL;
d2e4a39e 7741 else
14f9c5c9
AS
7742 {
7743 int len = strlen (ada_type_name (type));
5b4ee69b 7744
4c4b4cd2
PH
7745 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7746 return type;
14f9c5c9 7747 else
4c4b4cd2 7748 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
7749 }
7750}
7751
7752/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 7753 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 7754
d2e4a39e
AS
7755static int
7756is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
7757{
7758 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 7759
d2e4a39e 7760 return name != NULL
14f9c5c9
AS
7761 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
7762 && strstr (name, "___XVL") != NULL;
7763}
7764
4c4b4cd2
PH
7765/* The index of the variant field of TYPE, or -1 if TYPE does not
7766 represent a variant record type. */
14f9c5c9 7767
d2e4a39e 7768static int
4c4b4cd2 7769variant_field_index (struct type *type)
14f9c5c9
AS
7770{
7771 int f;
7772
4c4b4cd2
PH
7773 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
7774 return -1;
7775
7776 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
7777 {
7778 if (ada_is_variant_part (type, f))
7779 return f;
7780 }
7781 return -1;
14f9c5c9
AS
7782}
7783
4c4b4cd2
PH
7784/* A record type with no fields. */
7785
d2e4a39e 7786static struct type *
e9bb382b 7787empty_record (struct type *template)
14f9c5c9 7788{
e9bb382b 7789 struct type *type = alloc_type_copy (template);
5b4ee69b 7790
14f9c5c9
AS
7791 TYPE_CODE (type) = TYPE_CODE_STRUCT;
7792 TYPE_NFIELDS (type) = 0;
7793 TYPE_FIELDS (type) = NULL;
b1f33ddd 7794 INIT_CPLUS_SPECIFIC (type);
14f9c5c9
AS
7795 TYPE_NAME (type) = "<empty>";
7796 TYPE_TAG_NAME (type) = NULL;
14f9c5c9
AS
7797 TYPE_LENGTH (type) = 0;
7798 return type;
7799}
7800
7801/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
7802 the value of type TYPE at VALADDR or ADDRESS (see comments at
7803 the beginning of this section) VAL according to GNAT conventions.
7804 DVAL0 should describe the (portion of a) record that contains any
df407dfe 7805 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
7806 an outer-level type (i.e., as opposed to a branch of a variant.) A
7807 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 7808 of the variant.
14f9c5c9 7809
4c4b4cd2
PH
7810 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7811 length are not statically known are discarded. As a consequence,
7812 VALADDR, ADDRESS and DVAL0 are ignored.
7813
7814 NOTE: Limitations: For now, we assume that dynamic fields and
7815 variants occupy whole numbers of bytes. However, they need not be
7816 byte-aligned. */
7817
7818struct type *
10a2c479 7819ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 7820 const gdb_byte *valaddr,
4c4b4cd2
PH
7821 CORE_ADDR address, struct value *dval0,
7822 int keep_dynamic_fields)
14f9c5c9 7823{
d2e4a39e
AS
7824 struct value *mark = value_mark ();
7825 struct value *dval;
7826 struct type *rtype;
14f9c5c9 7827 int nfields, bit_len;
4c4b4cd2 7828 int variant_field;
14f9c5c9 7829 long off;
d94e4f4f 7830 int fld_bit_len;
14f9c5c9
AS
7831 int f;
7832
4c4b4cd2
PH
7833 /* Compute the number of fields in this record type that are going
7834 to be processed: unless keep_dynamic_fields, this includes only
7835 fields whose position and length are static will be processed. */
7836 if (keep_dynamic_fields)
7837 nfields = TYPE_NFIELDS (type);
7838 else
7839 {
7840 nfields = 0;
76a01679 7841 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
7842 && !ada_is_variant_part (type, nfields)
7843 && !is_dynamic_field (type, nfields))
7844 nfields++;
7845 }
7846
e9bb382b 7847 rtype = alloc_type_copy (type);
14f9c5c9
AS
7848 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7849 INIT_CPLUS_SPECIFIC (rtype);
7850 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 7851 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
7852 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7853 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
7854 TYPE_NAME (rtype) = ada_type_name (type);
7855 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7856 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 7857
d2e4a39e
AS
7858 off = 0;
7859 bit_len = 0;
4c4b4cd2
PH
7860 variant_field = -1;
7861
14f9c5c9
AS
7862 for (f = 0; f < nfields; f += 1)
7863 {
6c038f32
PH
7864 off = align_value (off, field_alignment (type, f))
7865 + TYPE_FIELD_BITPOS (type, f);
945b3a32 7866 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 7867 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 7868
d2e4a39e 7869 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
7870 {
7871 variant_field = f;
d94e4f4f 7872 fld_bit_len = 0;
4c4b4cd2 7873 }
14f9c5c9 7874 else if (is_dynamic_field (type, f))
4c4b4cd2 7875 {
284614f0
JB
7876 const gdb_byte *field_valaddr = valaddr;
7877 CORE_ADDR field_address = address;
7878 struct type *field_type =
7879 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
7880
4c4b4cd2 7881 if (dval0 == NULL)
b5304971
JG
7882 {
7883 /* rtype's length is computed based on the run-time
7884 value of discriminants. If the discriminants are not
7885 initialized, the type size may be completely bogus and
0963b4bd 7886 GDB may fail to allocate a value for it. So check the
b5304971
JG
7887 size first before creating the value. */
7888 check_size (rtype);
7889 dval = value_from_contents_and_address (rtype, valaddr, address);
7890 }
4c4b4cd2
PH
7891 else
7892 dval = dval0;
7893
284614f0
JB
7894 /* If the type referenced by this field is an aligner type, we need
7895 to unwrap that aligner type, because its size might not be set.
7896 Keeping the aligner type would cause us to compute the wrong
7897 size for this field, impacting the offset of the all the fields
7898 that follow this one. */
7899 if (ada_is_aligner_type (field_type))
7900 {
7901 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
7902
7903 field_valaddr = cond_offset_host (field_valaddr, field_offset);
7904 field_address = cond_offset_target (field_address, field_offset);
7905 field_type = ada_aligned_type (field_type);
7906 }
7907
7908 field_valaddr = cond_offset_host (field_valaddr,
7909 off / TARGET_CHAR_BIT);
7910 field_address = cond_offset_target (field_address,
7911 off / TARGET_CHAR_BIT);
7912
7913 /* Get the fixed type of the field. Note that, in this case,
7914 we do not want to get the real type out of the tag: if
7915 the current field is the parent part of a tagged record,
7916 we will get the tag of the object. Clearly wrong: the real
7917 type of the parent is not the real type of the child. We
7918 would end up in an infinite loop. */
7919 field_type = ada_get_base_type (field_type);
7920 field_type = ada_to_fixed_type (field_type, field_valaddr,
7921 field_address, dval, 0);
27f2a97b
JB
7922 /* If the field size is already larger than the maximum
7923 object size, then the record itself will necessarily
7924 be larger than the maximum object size. We need to make
7925 this check now, because the size might be so ridiculously
7926 large (due to an uninitialized variable in the inferior)
7927 that it would cause an overflow when adding it to the
7928 record size. */
7929 check_size (field_type);
284614f0
JB
7930
7931 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 7932 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
7933 /* The multiplication can potentially overflow. But because
7934 the field length has been size-checked just above, and
7935 assuming that the maximum size is a reasonable value,
7936 an overflow should not happen in practice. So rather than
7937 adding overflow recovery code to this already complex code,
7938 we just assume that it's not going to happen. */
d94e4f4f 7939 fld_bit_len =
4c4b4cd2
PH
7940 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
7941 }
14f9c5c9 7942 else
4c4b4cd2 7943 {
5ded5331
JB
7944 /* Note: If this field's type is a typedef, it is important
7945 to preserve the typedef layer.
7946
7947 Otherwise, we might be transforming a typedef to a fat
7948 pointer (encoding a pointer to an unconstrained array),
7949 into a basic fat pointer (encoding an unconstrained
7950 array). As both types are implemented using the same
7951 structure, the typedef is the only clue which allows us
7952 to distinguish between the two options. Stripping it
7953 would prevent us from printing this field appropriately. */
7954 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
7955 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7956 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 7957 fld_bit_len =
4c4b4cd2
PH
7958 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7959 else
5ded5331
JB
7960 {
7961 struct type *field_type = TYPE_FIELD_TYPE (type, f);
7962
7963 /* We need to be careful of typedefs when computing
7964 the length of our field. If this is a typedef,
7965 get the length of the target type, not the length
7966 of the typedef. */
7967 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
7968 field_type = ada_typedef_target_type (field_type);
7969
7970 fld_bit_len =
7971 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7972 }
4c4b4cd2 7973 }
14f9c5c9 7974 if (off + fld_bit_len > bit_len)
4c4b4cd2 7975 bit_len = off + fld_bit_len;
d94e4f4f 7976 off += fld_bit_len;
4c4b4cd2
PH
7977 TYPE_LENGTH (rtype) =
7978 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 7979 }
4c4b4cd2
PH
7980
7981 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 7982 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
7983 the record. This can happen in the presence of representation
7984 clauses. */
7985 if (variant_field >= 0)
7986 {
7987 struct type *branch_type;
7988
7989 off = TYPE_FIELD_BITPOS (rtype, variant_field);
7990
7991 if (dval0 == NULL)
7992 dval = value_from_contents_and_address (rtype, valaddr, address);
7993 else
7994 dval = dval0;
7995
7996 branch_type =
7997 to_fixed_variant_branch_type
7998 (TYPE_FIELD_TYPE (type, variant_field),
7999 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8000 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8001 if (branch_type == NULL)
8002 {
8003 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8004 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8005 TYPE_NFIELDS (rtype) -= 1;
8006 }
8007 else
8008 {
8009 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8010 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8011 fld_bit_len =
8012 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8013 TARGET_CHAR_BIT;
8014 if (off + fld_bit_len > bit_len)
8015 bit_len = off + fld_bit_len;
8016 TYPE_LENGTH (rtype) =
8017 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8018 }
8019 }
8020
714e53ab
PH
8021 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8022 should contain the alignment of that record, which should be a strictly
8023 positive value. If null or negative, then something is wrong, most
8024 probably in the debug info. In that case, we don't round up the size
0963b4bd 8025 of the resulting type. If this record is not part of another structure,
714e53ab
PH
8026 the current RTYPE length might be good enough for our purposes. */
8027 if (TYPE_LENGTH (type) <= 0)
8028 {
323e0a4a
AC
8029 if (TYPE_NAME (rtype))
8030 warning (_("Invalid type size for `%s' detected: %d."),
8031 TYPE_NAME (rtype), TYPE_LENGTH (type));
8032 else
8033 warning (_("Invalid type size for <unnamed> detected: %d."),
8034 TYPE_LENGTH (type));
714e53ab
PH
8035 }
8036 else
8037 {
8038 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8039 TYPE_LENGTH (type));
8040 }
14f9c5c9
AS
8041
8042 value_free_to_mark (mark);
d2e4a39e 8043 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 8044 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8045 return rtype;
8046}
8047
4c4b4cd2
PH
8048/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8049 of 1. */
14f9c5c9 8050
d2e4a39e 8051static struct type *
fc1a4b47 8052template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
8053 CORE_ADDR address, struct value *dval0)
8054{
8055 return ada_template_to_fixed_record_type_1 (type, valaddr,
8056 address, dval0, 1);
8057}
8058
8059/* An ordinary record type in which ___XVL-convention fields and
8060 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8061 static approximations, containing all possible fields. Uses
8062 no runtime values. Useless for use in values, but that's OK,
8063 since the results are used only for type determinations. Works on both
8064 structs and unions. Representation note: to save space, we memorize
8065 the result of this function in the TYPE_TARGET_TYPE of the
8066 template type. */
8067
8068static struct type *
8069template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
8070{
8071 struct type *type;
8072 int nfields;
8073 int f;
8074
4c4b4cd2
PH
8075 if (TYPE_TARGET_TYPE (type0) != NULL)
8076 return TYPE_TARGET_TYPE (type0);
8077
8078 nfields = TYPE_NFIELDS (type0);
8079 type = type0;
14f9c5c9
AS
8080
8081 for (f = 0; f < nfields; f += 1)
8082 {
61ee279c 8083 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
4c4b4cd2 8084 struct type *new_type;
14f9c5c9 8085
4c4b4cd2
PH
8086 if (is_dynamic_field (type0, f))
8087 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
14f9c5c9 8088 else
f192137b 8089 new_type = static_unwrap_type (field_type);
4c4b4cd2
PH
8090 if (type == type0 && new_type != field_type)
8091 {
e9bb382b 8092 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
4c4b4cd2
PH
8093 TYPE_CODE (type) = TYPE_CODE (type0);
8094 INIT_CPLUS_SPECIFIC (type);
8095 TYPE_NFIELDS (type) = nfields;
8096 TYPE_FIELDS (type) = (struct field *)
8097 TYPE_ALLOC (type, nfields * sizeof (struct field));
8098 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8099 sizeof (struct field) * nfields);
8100 TYPE_NAME (type) = ada_type_name (type0);
8101 TYPE_TAG_NAME (type) = NULL;
876cecd0 8102 TYPE_FIXED_INSTANCE (type) = 1;
4c4b4cd2
PH
8103 TYPE_LENGTH (type) = 0;
8104 }
8105 TYPE_FIELD_TYPE (type, f) = new_type;
8106 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
14f9c5c9 8107 }
14f9c5c9
AS
8108 return type;
8109}
8110
4c4b4cd2 8111/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
8112 whose address in memory is ADDRESS, returns a revision of TYPE,
8113 which should be a non-dynamic-sized record, in which the variant
8114 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
8115 for discriminant values in DVAL0, which can be NULL if the record
8116 contains the necessary discriminant values. */
8117
d2e4a39e 8118static struct type *
fc1a4b47 8119to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 8120 CORE_ADDR address, struct value *dval0)
14f9c5c9 8121{
d2e4a39e 8122 struct value *mark = value_mark ();
4c4b4cd2 8123 struct value *dval;
d2e4a39e 8124 struct type *rtype;
14f9c5c9
AS
8125 struct type *branch_type;
8126 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 8127 int variant_field = variant_field_index (type);
14f9c5c9 8128
4c4b4cd2 8129 if (variant_field == -1)
14f9c5c9
AS
8130 return type;
8131
4c4b4cd2
PH
8132 if (dval0 == NULL)
8133 dval = value_from_contents_and_address (type, valaddr, address);
8134 else
8135 dval = dval0;
8136
e9bb382b 8137 rtype = alloc_type_copy (type);
14f9c5c9 8138 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
8139 INIT_CPLUS_SPECIFIC (rtype);
8140 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
8141 TYPE_FIELDS (rtype) =
8142 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8143 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 8144 sizeof (struct field) * nfields);
14f9c5c9
AS
8145 TYPE_NAME (rtype) = ada_type_name (type);
8146 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 8147 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
8148 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8149
4c4b4cd2
PH
8150 branch_type = to_fixed_variant_branch_type
8151 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 8152 cond_offset_host (valaddr,
4c4b4cd2
PH
8153 TYPE_FIELD_BITPOS (type, variant_field)
8154 / TARGET_CHAR_BIT),
d2e4a39e 8155 cond_offset_target (address,
4c4b4cd2
PH
8156 TYPE_FIELD_BITPOS (type, variant_field)
8157 / TARGET_CHAR_BIT), dval);
d2e4a39e 8158 if (branch_type == NULL)
14f9c5c9 8159 {
4c4b4cd2 8160 int f;
5b4ee69b 8161
4c4b4cd2
PH
8162 for (f = variant_field + 1; f < nfields; f += 1)
8163 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 8164 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
8165 }
8166 else
8167 {
4c4b4cd2
PH
8168 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8169 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8170 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 8171 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 8172 }
4c4b4cd2 8173 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 8174
4c4b4cd2 8175 value_free_to_mark (mark);
14f9c5c9
AS
8176 return rtype;
8177}
8178
8179/* An ordinary record type (with fixed-length fields) that describes
8180 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8181 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
8182 should be in DVAL, a record value; it may be NULL if the object
8183 at ADDR itself contains any necessary discriminant values.
8184 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8185 values from the record are needed. Except in the case that DVAL,
8186 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8187 unchecked) is replaced by a particular branch of the variant.
8188
8189 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8190 is questionable and may be removed. It can arise during the
8191 processing of an unconstrained-array-of-record type where all the
8192 variant branches have exactly the same size. This is because in
8193 such cases, the compiler does not bother to use the XVS convention
8194 when encoding the record. I am currently dubious of this
8195 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 8196
d2e4a39e 8197static struct type *
fc1a4b47 8198to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 8199 CORE_ADDR address, struct value *dval)
14f9c5c9 8200{
d2e4a39e 8201 struct type *templ_type;
14f9c5c9 8202
876cecd0 8203 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8204 return type0;
8205
d2e4a39e 8206 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
8207
8208 if (templ_type != NULL)
8209 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
8210 else if (variant_field_index (type0) >= 0)
8211 {
8212 if (dval == NULL && valaddr == NULL && address == 0)
8213 return type0;
8214 return to_record_with_fixed_variant_part (type0, valaddr, address,
8215 dval);
8216 }
14f9c5c9
AS
8217 else
8218 {
876cecd0 8219 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
8220 return type0;
8221 }
8222
8223}
8224
8225/* An ordinary record type (with fixed-length fields) that describes
8226 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8227 union type. Any necessary discriminants' values should be in DVAL,
8228 a record value. That is, this routine selects the appropriate
8229 branch of the union at ADDR according to the discriminant value
b1f33ddd 8230 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8231 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8232
d2e4a39e 8233static struct type *
fc1a4b47 8234to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8235 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8236{
8237 int which;
d2e4a39e
AS
8238 struct type *templ_type;
8239 struct type *var_type;
14f9c5c9
AS
8240
8241 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8242 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8243 else
14f9c5c9
AS
8244 var_type = var_type0;
8245
8246 templ_type = ada_find_parallel_type (var_type, "___XVU");
8247
8248 if (templ_type != NULL)
8249 var_type = templ_type;
8250
b1f33ddd
JB
8251 if (is_unchecked_variant (var_type, value_type (dval)))
8252 return var_type0;
d2e4a39e
AS
8253 which =
8254 ada_which_variant_applies (var_type,
0fd88904 8255 value_type (dval), value_contents (dval));
14f9c5c9
AS
8256
8257 if (which < 0)
e9bb382b 8258 return empty_record (var_type);
14f9c5c9 8259 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8260 return to_fixed_record_type
d2e4a39e
AS
8261 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8262 valaddr, address, dval);
4c4b4cd2 8263 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8264 return
8265 to_fixed_record_type
8266 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8267 else
8268 return TYPE_FIELD_TYPE (var_type, which);
8269}
8270
8271/* Assuming that TYPE0 is an array type describing the type of a value
8272 at ADDR, and that DVAL describes a record containing any
8273 discriminants used in TYPE0, returns a type for the value that
8274 contains no dynamic components (that is, no components whose sizes
8275 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8276 true, gives an error message if the resulting type's size is over
4c4b4cd2 8277 varsize_limit. */
14f9c5c9 8278
d2e4a39e
AS
8279static struct type *
8280to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8281 int ignore_too_big)
14f9c5c9 8282{
d2e4a39e
AS
8283 struct type *index_type_desc;
8284 struct type *result;
ad82864c 8285 int constrained_packed_array_p;
14f9c5c9 8286
b0dd7688 8287 type0 = ada_check_typedef (type0);
284614f0 8288 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8289 return type0;
14f9c5c9 8290
ad82864c
JB
8291 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8292 if (constrained_packed_array_p)
8293 type0 = decode_constrained_packed_array_type (type0);
284614f0 8294
14f9c5c9 8295 index_type_desc = ada_find_parallel_type (type0, "___XA");
28c85d6c 8296 ada_fixup_array_indexes_type (index_type_desc);
14f9c5c9
AS
8297 if (index_type_desc == NULL)
8298 {
61ee279c 8299 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8300
14f9c5c9 8301 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8302 depend on the contents of the array in properly constructed
8303 debugging data. */
529cad9c
PH
8304 /* Create a fixed version of the array element type.
8305 We're not providing the address of an element here,
e1d5a0d2 8306 and thus the actual object value cannot be inspected to do
529cad9c
PH
8307 the conversion. This should not be a problem, since arrays of
8308 unconstrained objects are not allowed. In particular, all
8309 the elements of an array of a tagged type should all be of
8310 the same type specified in the debugging info. No need to
8311 consult the object tag. */
1ed6ede0 8312 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8313
284614f0
JB
8314 /* Make sure we always create a new array type when dealing with
8315 packed array types, since we're going to fix-up the array
8316 type length and element bitsize a little further down. */
ad82864c 8317 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8318 result = type0;
14f9c5c9 8319 else
e9bb382b 8320 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8321 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8322 }
8323 else
8324 {
8325 int i;
8326 struct type *elt_type0;
8327
8328 elt_type0 = type0;
8329 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8330 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8331
8332 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8333 depend on the contents of the array in properly constructed
8334 debugging data. */
529cad9c
PH
8335 /* Create a fixed version of the array element type.
8336 We're not providing the address of an element here,
e1d5a0d2 8337 and thus the actual object value cannot be inspected to do
529cad9c
PH
8338 the conversion. This should not be a problem, since arrays of
8339 unconstrained objects are not allowed. In particular, all
8340 the elements of an array of a tagged type should all be of
8341 the same type specified in the debugging info. No need to
8342 consult the object tag. */
1ed6ede0
JB
8343 result =
8344 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8345
8346 elt_type0 = type0;
14f9c5c9 8347 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8348 {
8349 struct type *range_type =
28c85d6c 8350 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8351
e9bb382b 8352 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8353 result, range_type);
1ce677a4 8354 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8355 }
d2e4a39e 8356 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8357 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8358 }
8359
2e6fda7d
JB
8360 /* We want to preserve the type name. This can be useful when
8361 trying to get the type name of a value that has already been
8362 printed (for instance, if the user did "print VAR; whatis $". */
8363 TYPE_NAME (result) = TYPE_NAME (type0);
8364
ad82864c 8365 if (constrained_packed_array_p)
284614f0
JB
8366 {
8367 /* So far, the resulting type has been created as if the original
8368 type was a regular (non-packed) array type. As a result, the
8369 bitsize of the array elements needs to be set again, and the array
8370 length needs to be recomputed based on that bitsize. */
8371 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8372 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8373
8374 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8375 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8376 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8377 TYPE_LENGTH (result)++;
8378 }
8379
876cecd0 8380 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8381 return result;
d2e4a39e 8382}
14f9c5c9
AS
8383
8384
8385/* A standard type (containing no dynamically sized components)
8386 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8387 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8388 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8389 ADDRESS or in VALADDR contains these discriminants.
8390
1ed6ede0
JB
8391 If CHECK_TAG is not null, in the case of tagged types, this function
8392 attempts to locate the object's tag and use it to compute the actual
8393 type. However, when ADDRESS is null, we cannot use it to determine the
8394 location of the tag, and therefore compute the tagged type's actual type.
8395 So we return the tagged type without consulting the tag. */
529cad9c 8396
f192137b
JB
8397static struct type *
8398ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 8399 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 8400{
61ee279c 8401 type = ada_check_typedef (type);
d2e4a39e
AS
8402 switch (TYPE_CODE (type))
8403 {
8404 default:
14f9c5c9 8405 return type;
d2e4a39e 8406 case TYPE_CODE_STRUCT:
4c4b4cd2 8407 {
76a01679 8408 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
8409 struct type *fixed_record_type =
8410 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 8411
529cad9c
PH
8412 /* If STATIC_TYPE is a tagged type and we know the object's address,
8413 then we can determine its tag, and compute the object's actual
0963b4bd 8414 type from there. Note that we have to use the fixed record
1ed6ede0
JB
8415 type (the parent part of the record may have dynamic fields
8416 and the way the location of _tag is expressed may depend on
8417 them). */
529cad9c 8418
1ed6ede0 8419 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 8420 {
b50d69b5
JG
8421 struct value *tag =
8422 value_tag_from_contents_and_address
8423 (fixed_record_type,
8424 valaddr,
8425 address);
8426 struct type *real_type = type_from_tag (tag);
8427 struct value *obj =
8428 value_from_contents_and_address (fixed_record_type,
8429 valaddr,
8430 address);
76a01679 8431 if (real_type != NULL)
b50d69b5
JG
8432 return to_fixed_record_type
8433 (real_type, NULL,
8434 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 8435 }
4af88198
JB
8436
8437 /* Check to see if there is a parallel ___XVZ variable.
8438 If there is, then it provides the actual size of our type. */
8439 else if (ada_type_name (fixed_record_type) != NULL)
8440 {
0d5cff50 8441 const char *name = ada_type_name (fixed_record_type);
4af88198
JB
8442 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
8443 int xvz_found = 0;
8444 LONGEST size;
8445
88c15c34 8446 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
4af88198
JB
8447 size = get_int_var_value (xvz_name, &xvz_found);
8448 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8449 {
8450 fixed_record_type = copy_type (fixed_record_type);
8451 TYPE_LENGTH (fixed_record_type) = size;
8452
8453 /* The FIXED_RECORD_TYPE may have be a stub. We have
8454 observed this when the debugging info is STABS, and
8455 apparently it is something that is hard to fix.
8456
8457 In practice, we don't need the actual type definition
8458 at all, because the presence of the XVZ variable allows us
8459 to assume that there must be a XVS type as well, which we
8460 should be able to use later, when we need the actual type
8461 definition.
8462
8463 In the meantime, pretend that the "fixed" type we are
8464 returning is NOT a stub, because this can cause trouble
8465 when using this type to create new types targeting it.
8466 Indeed, the associated creation routines often check
8467 whether the target type is a stub and will try to replace
0963b4bd 8468 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
8469 might cause the new type to have the wrong size too.
8470 Consider the case of an array, for instance, where the size
8471 of the array is computed from the number of elements in
8472 our array multiplied by the size of its element. */
8473 TYPE_STUB (fixed_record_type) = 0;
8474 }
8475 }
1ed6ede0 8476 return fixed_record_type;
4c4b4cd2 8477 }
d2e4a39e 8478 case TYPE_CODE_ARRAY:
4c4b4cd2 8479 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
8480 case TYPE_CODE_UNION:
8481 if (dval == NULL)
4c4b4cd2 8482 return type;
d2e4a39e 8483 else
4c4b4cd2 8484 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 8485 }
14f9c5c9
AS
8486}
8487
f192137b
JB
8488/* The same as ada_to_fixed_type_1, except that it preserves the type
8489 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
8490
8491 The typedef layer needs be preserved in order to differentiate between
8492 arrays and array pointers when both types are implemented using the same
8493 fat pointer. In the array pointer case, the pointer is encoded as
8494 a typedef of the pointer type. For instance, considering:
8495
8496 type String_Access is access String;
8497 S1 : String_Access := null;
8498
8499 To the debugger, S1 is defined as a typedef of type String. But
8500 to the user, it is a pointer. So if the user tries to print S1,
8501 we should not dereference the array, but print the array address
8502 instead.
8503
8504 If we didn't preserve the typedef layer, we would lose the fact that
8505 the type is to be presented as a pointer (needs de-reference before
8506 being printed). And we would also use the source-level type name. */
f192137b
JB
8507
8508struct type *
8509ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8510 CORE_ADDR address, struct value *dval, int check_tag)
8511
8512{
8513 struct type *fixed_type =
8514 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8515
96dbd2c1
JB
8516 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8517 then preserve the typedef layer.
8518
8519 Implementation note: We can only check the main-type portion of
8520 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8521 from TYPE now returns a type that has the same instance flags
8522 as TYPE. For instance, if TYPE is a "typedef const", and its
8523 target type is a "struct", then the typedef elimination will return
8524 a "const" version of the target type. See check_typedef for more
8525 details about how the typedef layer elimination is done.
8526
8527 brobecker/2010-11-19: It seems to me that the only case where it is
8528 useful to preserve the typedef layer is when dealing with fat pointers.
8529 Perhaps, we could add a check for that and preserve the typedef layer
8530 only in that situation. But this seems unecessary so far, probably
8531 because we call check_typedef/ada_check_typedef pretty much everywhere.
8532 */
f192137b 8533 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 8534 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 8535 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
8536 return type;
8537
8538 return fixed_type;
8539}
8540
14f9c5c9 8541/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 8542 TYPE0, but based on no runtime data. */
14f9c5c9 8543
d2e4a39e
AS
8544static struct type *
8545to_static_fixed_type (struct type *type0)
14f9c5c9 8546{
d2e4a39e 8547 struct type *type;
14f9c5c9
AS
8548
8549 if (type0 == NULL)
8550 return NULL;
8551
876cecd0 8552 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8553 return type0;
8554
61ee279c 8555 type0 = ada_check_typedef (type0);
d2e4a39e 8556
14f9c5c9
AS
8557 switch (TYPE_CODE (type0))
8558 {
8559 default:
8560 return type0;
8561 case TYPE_CODE_STRUCT:
8562 type = dynamic_template_type (type0);
d2e4a39e 8563 if (type != NULL)
4c4b4cd2
PH
8564 return template_to_static_fixed_type (type);
8565 else
8566 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8567 case TYPE_CODE_UNION:
8568 type = ada_find_parallel_type (type0, "___XVU");
8569 if (type != NULL)
4c4b4cd2
PH
8570 return template_to_static_fixed_type (type);
8571 else
8572 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8573 }
8574}
8575
4c4b4cd2
PH
8576/* A static approximation of TYPE with all type wrappers removed. */
8577
d2e4a39e
AS
8578static struct type *
8579static_unwrap_type (struct type *type)
14f9c5c9
AS
8580{
8581 if (ada_is_aligner_type (type))
8582 {
61ee279c 8583 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 8584 if (ada_type_name (type1) == NULL)
4c4b4cd2 8585 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
8586
8587 return static_unwrap_type (type1);
8588 }
d2e4a39e 8589 else
14f9c5c9 8590 {
d2e4a39e 8591 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 8592
d2e4a39e 8593 if (raw_real_type == type)
4c4b4cd2 8594 return type;
14f9c5c9 8595 else
4c4b4cd2 8596 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
8597 }
8598}
8599
8600/* In some cases, incomplete and private types require
4c4b4cd2 8601 cross-references that are not resolved as records (for example,
14f9c5c9
AS
8602 type Foo;
8603 type FooP is access Foo;
8604 V: FooP;
8605 type Foo is array ...;
4c4b4cd2 8606 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
8607 cross-references to such types, we instead substitute for FooP a
8608 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 8609 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
8610
8611/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
8612 exists, otherwise TYPE. */
8613
d2e4a39e 8614struct type *
61ee279c 8615ada_check_typedef (struct type *type)
14f9c5c9 8616{
727e3d2e
JB
8617 if (type == NULL)
8618 return NULL;
8619
720d1a40
JB
8620 /* If our type is a typedef type of a fat pointer, then we're done.
8621 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8622 what allows us to distinguish between fat pointers that represent
8623 array types, and fat pointers that represent array access types
8624 (in both cases, the compiler implements them as fat pointers). */
8625 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8626 && is_thick_pntr (ada_typedef_target_type (type)))
8627 return type;
8628
14f9c5c9
AS
8629 CHECK_TYPEDEF (type);
8630 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 8631 || !TYPE_STUB (type)
14f9c5c9
AS
8632 || TYPE_TAG_NAME (type) == NULL)
8633 return type;
d2e4a39e 8634 else
14f9c5c9 8635 {
0d5cff50 8636 const char *name = TYPE_TAG_NAME (type);
d2e4a39e 8637 struct type *type1 = ada_find_any_type (name);
5b4ee69b 8638
05e522ef
JB
8639 if (type1 == NULL)
8640 return type;
8641
8642 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8643 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
8644 types, only for the typedef-to-array types). If that's the case,
8645 strip the typedef layer. */
8646 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
8647 type1 = ada_check_typedef (type1);
8648
8649 return type1;
14f9c5c9
AS
8650 }
8651}
8652
8653/* A value representing the data at VALADDR/ADDRESS as described by
8654 type TYPE0, but with a standard (static-sized) type that correctly
8655 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8656 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 8657 creation of struct values]. */
14f9c5c9 8658
4c4b4cd2
PH
8659static struct value *
8660ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8661 struct value *val0)
14f9c5c9 8662{
1ed6ede0 8663 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 8664
14f9c5c9
AS
8665 if (type == type0 && val0 != NULL)
8666 return val0;
d2e4a39e 8667 else
4c4b4cd2
PH
8668 return value_from_contents_and_address (type, 0, address);
8669}
8670
8671/* A value representing VAL, but with a standard (static-sized) type
8672 that correctly describes it. Does not necessarily create a new
8673 value. */
8674
0c3acc09 8675struct value *
4c4b4cd2
PH
8676ada_to_fixed_value (struct value *val)
8677{
c48db5ca
JB
8678 val = unwrap_value (val);
8679 val = ada_to_fixed_value_create (value_type (val),
8680 value_address (val),
8681 val);
8682 return val;
14f9c5c9 8683}
d2e4a39e 8684\f
14f9c5c9 8685
14f9c5c9
AS
8686/* Attributes */
8687
4c4b4cd2
PH
8688/* Table mapping attribute numbers to names.
8689 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 8690
d2e4a39e 8691static const char *attribute_names[] = {
14f9c5c9
AS
8692 "<?>",
8693
d2e4a39e 8694 "first",
14f9c5c9
AS
8695 "last",
8696 "length",
8697 "image",
14f9c5c9
AS
8698 "max",
8699 "min",
4c4b4cd2
PH
8700 "modulus",
8701 "pos",
8702 "size",
8703 "tag",
14f9c5c9 8704 "val",
14f9c5c9
AS
8705 0
8706};
8707
d2e4a39e 8708const char *
4c4b4cd2 8709ada_attribute_name (enum exp_opcode n)
14f9c5c9 8710{
4c4b4cd2
PH
8711 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8712 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
8713 else
8714 return attribute_names[0];
8715}
8716
4c4b4cd2 8717/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 8718
4c4b4cd2
PH
8719static LONGEST
8720pos_atr (struct value *arg)
14f9c5c9 8721{
24209737
PH
8722 struct value *val = coerce_ref (arg);
8723 struct type *type = value_type (val);
14f9c5c9 8724
d2e4a39e 8725 if (!discrete_type_p (type))
323e0a4a 8726 error (_("'POS only defined on discrete types"));
14f9c5c9
AS
8727
8728 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8729 {
8730 int i;
24209737 8731 LONGEST v = value_as_long (val);
14f9c5c9 8732
d2e4a39e 8733 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2 8734 {
14e75d8e 8735 if (v == TYPE_FIELD_ENUMVAL (type, i))
4c4b4cd2
PH
8736 return i;
8737 }
323e0a4a 8738 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9
AS
8739 }
8740 else
24209737 8741 return value_as_long (val);
4c4b4cd2
PH
8742}
8743
8744static struct value *
3cb382c9 8745value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 8746{
3cb382c9 8747 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
8748}
8749
4c4b4cd2 8750/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 8751
d2e4a39e
AS
8752static struct value *
8753value_val_atr (struct type *type, struct value *arg)
14f9c5c9 8754{
d2e4a39e 8755 if (!discrete_type_p (type))
323e0a4a 8756 error (_("'VAL only defined on discrete types"));
df407dfe 8757 if (!integer_type_p (value_type (arg)))
323e0a4a 8758 error (_("'VAL requires integral argument"));
14f9c5c9
AS
8759
8760 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8761 {
8762 long pos = value_as_long (arg);
5b4ee69b 8763
14f9c5c9 8764 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 8765 error (_("argument to 'VAL out of range"));
14e75d8e 8766 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
8767 }
8768 else
8769 return value_from_longest (type, value_as_long (arg));
8770}
14f9c5c9 8771\f
d2e4a39e 8772
4c4b4cd2 8773 /* Evaluation */
14f9c5c9 8774
4c4b4cd2
PH
8775/* True if TYPE appears to be an Ada character type.
8776 [At the moment, this is true only for Character and Wide_Character;
8777 It is a heuristic test that could stand improvement]. */
14f9c5c9 8778
d2e4a39e
AS
8779int
8780ada_is_character_type (struct type *type)
14f9c5c9 8781{
7b9f71f2
JB
8782 const char *name;
8783
8784 /* If the type code says it's a character, then assume it really is,
8785 and don't check any further. */
8786 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
8787 return 1;
8788
8789 /* Otherwise, assume it's a character type iff it is a discrete type
8790 with a known character type name. */
8791 name = ada_type_name (type);
8792 return (name != NULL
8793 && (TYPE_CODE (type) == TYPE_CODE_INT
8794 || TYPE_CODE (type) == TYPE_CODE_RANGE)
8795 && (strcmp (name, "character") == 0
8796 || strcmp (name, "wide_character") == 0
5a517ebd 8797 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 8798 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
8799}
8800
4c4b4cd2 8801/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
8802
8803int
ebf56fd3 8804ada_is_string_type (struct type *type)
14f9c5c9 8805{
61ee279c 8806 type = ada_check_typedef (type);
d2e4a39e 8807 if (type != NULL
14f9c5c9 8808 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
8809 && (ada_is_simple_array_type (type)
8810 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
8811 && ada_array_arity (type) == 1)
8812 {
8813 struct type *elttype = ada_array_element_type (type, 1);
8814
8815 return ada_is_character_type (elttype);
8816 }
d2e4a39e 8817 else
14f9c5c9
AS
8818 return 0;
8819}
8820
5bf03f13
JB
8821/* The compiler sometimes provides a parallel XVS type for a given
8822 PAD type. Normally, it is safe to follow the PAD type directly,
8823 but older versions of the compiler have a bug that causes the offset
8824 of its "F" field to be wrong. Following that field in that case
8825 would lead to incorrect results, but this can be worked around
8826 by ignoring the PAD type and using the associated XVS type instead.
8827
8828 Set to True if the debugger should trust the contents of PAD types.
8829 Otherwise, ignore the PAD type if there is a parallel XVS type. */
8830static int trust_pad_over_xvs = 1;
14f9c5c9
AS
8831
8832/* True if TYPE is a struct type introduced by the compiler to force the
8833 alignment of a value. Such types have a single field with a
4c4b4cd2 8834 distinctive name. */
14f9c5c9
AS
8835
8836int
ebf56fd3 8837ada_is_aligner_type (struct type *type)
14f9c5c9 8838{
61ee279c 8839 type = ada_check_typedef (type);
714e53ab 8840
5bf03f13 8841 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
8842 return 0;
8843
14f9c5c9 8844 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
8845 && TYPE_NFIELDS (type) == 1
8846 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
8847}
8848
8849/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 8850 the parallel type. */
14f9c5c9 8851
d2e4a39e
AS
8852struct type *
8853ada_get_base_type (struct type *raw_type)
14f9c5c9 8854{
d2e4a39e
AS
8855 struct type *real_type_namer;
8856 struct type *raw_real_type;
14f9c5c9
AS
8857
8858 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
8859 return raw_type;
8860
284614f0
JB
8861 if (ada_is_aligner_type (raw_type))
8862 /* The encoding specifies that we should always use the aligner type.
8863 So, even if this aligner type has an associated XVS type, we should
8864 simply ignore it.
8865
8866 According to the compiler gurus, an XVS type parallel to an aligner
8867 type may exist because of a stabs limitation. In stabs, aligner
8868 types are empty because the field has a variable-sized type, and
8869 thus cannot actually be used as an aligner type. As a result,
8870 we need the associated parallel XVS type to decode the type.
8871 Since the policy in the compiler is to not change the internal
8872 representation based on the debugging info format, we sometimes
8873 end up having a redundant XVS type parallel to the aligner type. */
8874 return raw_type;
8875
14f9c5c9 8876 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 8877 if (real_type_namer == NULL
14f9c5c9
AS
8878 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
8879 || TYPE_NFIELDS (real_type_namer) != 1)
8880 return raw_type;
8881
f80d3ff2
JB
8882 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
8883 {
8884 /* This is an older encoding form where the base type needs to be
8885 looked up by name. We prefer the newer enconding because it is
8886 more efficient. */
8887 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
8888 if (raw_real_type == NULL)
8889 return raw_type;
8890 else
8891 return raw_real_type;
8892 }
8893
8894 /* The field in our XVS type is a reference to the base type. */
8895 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 8896}
14f9c5c9 8897
4c4b4cd2 8898/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 8899
d2e4a39e
AS
8900struct type *
8901ada_aligned_type (struct type *type)
14f9c5c9
AS
8902{
8903 if (ada_is_aligner_type (type))
8904 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
8905 else
8906 return ada_get_base_type (type);
8907}
8908
8909
8910/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 8911 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 8912
fc1a4b47
AC
8913const gdb_byte *
8914ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 8915{
d2e4a39e 8916 if (ada_is_aligner_type (type))
14f9c5c9 8917 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
8918 valaddr +
8919 TYPE_FIELD_BITPOS (type,
8920 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
8921 else
8922 return valaddr;
8923}
8924
4c4b4cd2
PH
8925
8926
14f9c5c9 8927/* The printed representation of an enumeration literal with encoded
4c4b4cd2 8928 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
8929const char *
8930ada_enum_name (const char *name)
14f9c5c9 8931{
4c4b4cd2
PH
8932 static char *result;
8933 static size_t result_len = 0;
d2e4a39e 8934 char *tmp;
14f9c5c9 8935
4c4b4cd2
PH
8936 /* First, unqualify the enumeration name:
8937 1. Search for the last '.' character. If we find one, then skip
177b42fe 8938 all the preceding characters, the unqualified name starts
76a01679 8939 right after that dot.
4c4b4cd2 8940 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
8941 translates dots into "__". Search forward for double underscores,
8942 but stop searching when we hit an overloading suffix, which is
8943 of the form "__" followed by digits. */
4c4b4cd2 8944
c3e5cd34
PH
8945 tmp = strrchr (name, '.');
8946 if (tmp != NULL)
4c4b4cd2
PH
8947 name = tmp + 1;
8948 else
14f9c5c9 8949 {
4c4b4cd2
PH
8950 while ((tmp = strstr (name, "__")) != NULL)
8951 {
8952 if (isdigit (tmp[2]))
8953 break;
8954 else
8955 name = tmp + 2;
8956 }
14f9c5c9
AS
8957 }
8958
8959 if (name[0] == 'Q')
8960 {
14f9c5c9 8961 int v;
5b4ee69b 8962
14f9c5c9 8963 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
8964 {
8965 if (sscanf (name + 2, "%x", &v) != 1)
8966 return name;
8967 }
14f9c5c9 8968 else
4c4b4cd2 8969 return name;
14f9c5c9 8970
4c4b4cd2 8971 GROW_VECT (result, result_len, 16);
14f9c5c9 8972 if (isascii (v) && isprint (v))
88c15c34 8973 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 8974 else if (name[1] == 'U')
88c15c34 8975 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 8976 else
88c15c34 8977 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
8978
8979 return result;
8980 }
d2e4a39e 8981 else
4c4b4cd2 8982 {
c3e5cd34
PH
8983 tmp = strstr (name, "__");
8984 if (tmp == NULL)
8985 tmp = strstr (name, "$");
8986 if (tmp != NULL)
4c4b4cd2
PH
8987 {
8988 GROW_VECT (result, result_len, tmp - name + 1);
8989 strncpy (result, name, tmp - name);
8990 result[tmp - name] = '\0';
8991 return result;
8992 }
8993
8994 return name;
8995 }
14f9c5c9
AS
8996}
8997
14f9c5c9
AS
8998/* Evaluate the subexpression of EXP starting at *POS as for
8999 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 9000 expression. */
14f9c5c9 9001
d2e4a39e
AS
9002static struct value *
9003evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 9004{
4b27a620 9005 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
9006}
9007
9008/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 9009 value it wraps. */
14f9c5c9 9010
d2e4a39e
AS
9011static struct value *
9012unwrap_value (struct value *val)
14f9c5c9 9013{
df407dfe 9014 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 9015
14f9c5c9
AS
9016 if (ada_is_aligner_type (type))
9017 {
de4d072f 9018 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 9019 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 9020
14f9c5c9 9021 if (ada_type_name (val_type) == NULL)
4c4b4cd2 9022 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
9023
9024 return unwrap_value (v);
9025 }
d2e4a39e 9026 else
14f9c5c9 9027 {
d2e4a39e 9028 struct type *raw_real_type =
61ee279c 9029 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 9030
5bf03f13
JB
9031 /* If there is no parallel XVS or XVE type, then the value is
9032 already unwrapped. Return it without further modification. */
9033 if ((type == raw_real_type)
9034 && ada_find_parallel_type (type, "___XVE") == NULL)
9035 return val;
14f9c5c9 9036
d2e4a39e 9037 return
4c4b4cd2
PH
9038 coerce_unspec_val_to_type
9039 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 9040 value_address (val),
1ed6ede0 9041 NULL, 1));
14f9c5c9
AS
9042 }
9043}
d2e4a39e
AS
9044
9045static struct value *
9046cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
9047{
9048 LONGEST val;
9049
df407dfe 9050 if (type == value_type (arg))
14f9c5c9 9051 return arg;
df407dfe 9052 else if (ada_is_fixed_point_type (value_type (arg)))
d2e4a39e 9053 val = ada_float_to_fixed (type,
df407dfe 9054 ada_fixed_to_float (value_type (arg),
4c4b4cd2 9055 value_as_long (arg)));
d2e4a39e 9056 else
14f9c5c9 9057 {
a53b7a21 9058 DOUBLEST argd = value_as_double (arg);
5b4ee69b 9059
14f9c5c9
AS
9060 val = ada_float_to_fixed (type, argd);
9061 }
9062
9063 return value_from_longest (type, val);
9064}
9065
d2e4a39e 9066static struct value *
a53b7a21 9067cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 9068{
df407dfe 9069 DOUBLEST val = ada_fixed_to_float (value_type (arg),
4c4b4cd2 9070 value_as_long (arg));
5b4ee69b 9071
a53b7a21 9072 return value_from_double (type, val);
14f9c5c9
AS
9073}
9074
d99dcf51
JB
9075/* Given two array types T1 and T2, return nonzero iff both arrays
9076 contain the same number of elements. */
9077
9078static int
9079ada_same_array_size_p (struct type *t1, struct type *t2)
9080{
9081 LONGEST lo1, hi1, lo2, hi2;
9082
9083 /* Get the array bounds in order to verify that the size of
9084 the two arrays match. */
9085 if (!get_array_bounds (t1, &lo1, &hi1)
9086 || !get_array_bounds (t2, &lo2, &hi2))
9087 error (_("unable to determine array bounds"));
9088
9089 /* To make things easier for size comparison, normalize a bit
9090 the case of empty arrays by making sure that the difference
9091 between upper bound and lower bound is always -1. */
9092 if (lo1 > hi1)
9093 hi1 = lo1 - 1;
9094 if (lo2 > hi2)
9095 hi2 = lo2 - 1;
9096
9097 return (hi1 - lo1 == hi2 - lo2);
9098}
9099
9100/* Assuming that VAL is an array of integrals, and TYPE represents
9101 an array with the same number of elements, but with wider integral
9102 elements, return an array "casted" to TYPE. In practice, this
9103 means that the returned array is built by casting each element
9104 of the original array into TYPE's (wider) element type. */
9105
9106static struct value *
9107ada_promote_array_of_integrals (struct type *type, struct value *val)
9108{
9109 struct type *elt_type = TYPE_TARGET_TYPE (type);
9110 LONGEST lo, hi;
9111 struct value *res;
9112 LONGEST i;
9113
9114 /* Verify that both val and type are arrays of scalars, and
9115 that the size of val's elements is smaller than the size
9116 of type's element. */
9117 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9118 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9119 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9120 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9121 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9122 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9123
9124 if (!get_array_bounds (type, &lo, &hi))
9125 error (_("unable to determine array bounds"));
9126
9127 res = allocate_value (type);
9128
9129 /* Promote each array element. */
9130 for (i = 0; i < hi - lo + 1; i++)
9131 {
9132 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9133
9134 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9135 value_contents_all (elt), TYPE_LENGTH (elt_type));
9136 }
9137
9138 return res;
9139}
9140
4c4b4cd2
PH
9141/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9142 return the converted value. */
9143
d2e4a39e
AS
9144static struct value *
9145coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 9146{
df407dfe 9147 struct type *type2 = value_type (val);
5b4ee69b 9148
14f9c5c9
AS
9149 if (type == type2)
9150 return val;
9151
61ee279c
PH
9152 type2 = ada_check_typedef (type2);
9153 type = ada_check_typedef (type);
14f9c5c9 9154
d2e4a39e
AS
9155 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9156 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
9157 {
9158 val = ada_value_ind (val);
df407dfe 9159 type2 = value_type (val);
14f9c5c9
AS
9160 }
9161
d2e4a39e 9162 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
9163 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9164 {
d99dcf51
JB
9165 if (!ada_same_array_size_p (type, type2))
9166 error (_("cannot assign arrays of different length"));
9167
9168 if (is_integral_type (TYPE_TARGET_TYPE (type))
9169 && is_integral_type (TYPE_TARGET_TYPE (type2))
9170 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9171 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9172 {
9173 /* Allow implicit promotion of the array elements to
9174 a wider type. */
9175 return ada_promote_array_of_integrals (type, val);
9176 }
9177
9178 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9179 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 9180 error (_("Incompatible types in assignment"));
04624583 9181 deprecated_set_value_type (val, type);
14f9c5c9 9182 }
d2e4a39e 9183 return val;
14f9c5c9
AS
9184}
9185
4c4b4cd2
PH
9186static struct value *
9187ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9188{
9189 struct value *val;
9190 struct type *type1, *type2;
9191 LONGEST v, v1, v2;
9192
994b9211
AC
9193 arg1 = coerce_ref (arg1);
9194 arg2 = coerce_ref (arg2);
18af8284
JB
9195 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9196 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 9197
76a01679
JB
9198 if (TYPE_CODE (type1) != TYPE_CODE_INT
9199 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
9200 return value_binop (arg1, arg2, op);
9201
76a01679 9202 switch (op)
4c4b4cd2
PH
9203 {
9204 case BINOP_MOD:
9205 case BINOP_DIV:
9206 case BINOP_REM:
9207 break;
9208 default:
9209 return value_binop (arg1, arg2, op);
9210 }
9211
9212 v2 = value_as_long (arg2);
9213 if (v2 == 0)
323e0a4a 9214 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
9215
9216 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9217 return value_binop (arg1, arg2, op);
9218
9219 v1 = value_as_long (arg1);
9220 switch (op)
9221 {
9222 case BINOP_DIV:
9223 v = v1 / v2;
76a01679
JB
9224 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9225 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
9226 break;
9227 case BINOP_REM:
9228 v = v1 % v2;
76a01679
JB
9229 if (v * v1 < 0)
9230 v -= v2;
4c4b4cd2
PH
9231 break;
9232 default:
9233 /* Should not reach this point. */
9234 v = 0;
9235 }
9236
9237 val = allocate_value (type1);
990a07ab 9238 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9239 TYPE_LENGTH (value_type (val)),
9240 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9241 return val;
9242}
9243
9244static int
9245ada_value_equal (struct value *arg1, struct value *arg2)
9246{
df407dfe
AC
9247 if (ada_is_direct_array_type (value_type (arg1))
9248 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9249 {
f58b38bf
JB
9250 /* Automatically dereference any array reference before
9251 we attempt to perform the comparison. */
9252 arg1 = ada_coerce_ref (arg1);
9253 arg2 = ada_coerce_ref (arg2);
9254
4c4b4cd2
PH
9255 arg1 = ada_coerce_to_simple_array (arg1);
9256 arg2 = ada_coerce_to_simple_array (arg2);
df407dfe
AC
9257 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
9258 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
323e0a4a 9259 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9260 /* FIXME: The following works only for types whose
76a01679
JB
9261 representations use all bits (no padding or undefined bits)
9262 and do not have user-defined equality. */
9263 return
df407dfe 9264 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
0fd88904 9265 && memcmp (value_contents (arg1), value_contents (arg2),
df407dfe 9266 TYPE_LENGTH (value_type (arg1))) == 0;
4c4b4cd2
PH
9267 }
9268 return value_equal (arg1, arg2);
9269}
9270
52ce6436
PH
9271/* Total number of component associations in the aggregate starting at
9272 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9273 OP_AGGREGATE. */
52ce6436
PH
9274
9275static int
9276num_component_specs (struct expression *exp, int pc)
9277{
9278 int n, m, i;
5b4ee69b 9279
52ce6436
PH
9280 m = exp->elts[pc + 1].longconst;
9281 pc += 3;
9282 n = 0;
9283 for (i = 0; i < m; i += 1)
9284 {
9285 switch (exp->elts[pc].opcode)
9286 {
9287 default:
9288 n += 1;
9289 break;
9290 case OP_CHOICES:
9291 n += exp->elts[pc + 1].longconst;
9292 break;
9293 }
9294 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9295 }
9296 return n;
9297}
9298
9299/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9300 component of LHS (a simple array or a record), updating *POS past
9301 the expression, assuming that LHS is contained in CONTAINER. Does
9302 not modify the inferior's memory, nor does it modify LHS (unless
9303 LHS == CONTAINER). */
9304
9305static void
9306assign_component (struct value *container, struct value *lhs, LONGEST index,
9307 struct expression *exp, int *pos)
9308{
9309 struct value *mark = value_mark ();
9310 struct value *elt;
5b4ee69b 9311
52ce6436
PH
9312 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
9313 {
22601c15
UW
9314 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9315 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9316
52ce6436
PH
9317 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9318 }
9319 else
9320 {
9321 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9322 elt = ada_to_fixed_value (elt);
52ce6436
PH
9323 }
9324
9325 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9326 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9327 else
9328 value_assign_to_component (container, elt,
9329 ada_evaluate_subexp (NULL, exp, pos,
9330 EVAL_NORMAL));
9331
9332 value_free_to_mark (mark);
9333}
9334
9335/* Assuming that LHS represents an lvalue having a record or array
9336 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9337 of that aggregate's value to LHS, advancing *POS past the
9338 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9339 lvalue containing LHS (possibly LHS itself). Does not modify
9340 the inferior's memory, nor does it modify the contents of
0963b4bd 9341 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9342
9343static struct value *
9344assign_aggregate (struct value *container,
9345 struct value *lhs, struct expression *exp,
9346 int *pos, enum noside noside)
9347{
9348 struct type *lhs_type;
9349 int n = exp->elts[*pos+1].longconst;
9350 LONGEST low_index, high_index;
9351 int num_specs;
9352 LONGEST *indices;
9353 int max_indices, num_indices;
52ce6436 9354 int i;
52ce6436
PH
9355
9356 *pos += 3;
9357 if (noside != EVAL_NORMAL)
9358 {
52ce6436
PH
9359 for (i = 0; i < n; i += 1)
9360 ada_evaluate_subexp (NULL, exp, pos, noside);
9361 return container;
9362 }
9363
9364 container = ada_coerce_ref (container);
9365 if (ada_is_direct_array_type (value_type (container)))
9366 container = ada_coerce_to_simple_array (container);
9367 lhs = ada_coerce_ref (lhs);
9368 if (!deprecated_value_modifiable (lhs))
9369 error (_("Left operand of assignment is not a modifiable lvalue."));
9370
9371 lhs_type = value_type (lhs);
9372 if (ada_is_direct_array_type (lhs_type))
9373 {
9374 lhs = ada_coerce_to_simple_array (lhs);
9375 lhs_type = value_type (lhs);
9376 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9377 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
9378 }
9379 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9380 {
9381 low_index = 0;
9382 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
9383 }
9384 else
9385 error (_("Left-hand side must be array or record."));
9386
9387 num_specs = num_component_specs (exp, *pos - 3);
9388 max_indices = 4 * num_specs + 4;
9389 indices = alloca (max_indices * sizeof (indices[0]));
9390 indices[0] = indices[1] = low_index - 1;
9391 indices[2] = indices[3] = high_index + 1;
9392 num_indices = 4;
9393
9394 for (i = 0; i < n; i += 1)
9395 {
9396 switch (exp->elts[*pos].opcode)
9397 {
1fbf5ada
JB
9398 case OP_CHOICES:
9399 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9400 &num_indices, max_indices,
9401 low_index, high_index);
9402 break;
9403 case OP_POSITIONAL:
9404 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
9405 &num_indices, max_indices,
9406 low_index, high_index);
1fbf5ada
JB
9407 break;
9408 case OP_OTHERS:
9409 if (i != n-1)
9410 error (_("Misplaced 'others' clause"));
9411 aggregate_assign_others (container, lhs, exp, pos, indices,
9412 num_indices, low_index, high_index);
9413 break;
9414 default:
9415 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
9416 }
9417 }
9418
9419 return container;
9420}
9421
9422/* Assign into the component of LHS indexed by the OP_POSITIONAL
9423 construct at *POS, updating *POS past the construct, given that
9424 the positions are relative to lower bound LOW, where HIGH is the
9425 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9426 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 9427 assign_aggregate. */
52ce6436
PH
9428static void
9429aggregate_assign_positional (struct value *container,
9430 struct value *lhs, struct expression *exp,
9431 int *pos, LONGEST *indices, int *num_indices,
9432 int max_indices, LONGEST low, LONGEST high)
9433{
9434 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9435
9436 if (ind - 1 == high)
e1d5a0d2 9437 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
9438 if (ind <= high)
9439 {
9440 add_component_interval (ind, ind, indices, num_indices, max_indices);
9441 *pos += 3;
9442 assign_component (container, lhs, ind, exp, pos);
9443 }
9444 else
9445 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9446}
9447
9448/* Assign into the components of LHS indexed by the OP_CHOICES
9449 construct at *POS, updating *POS past the construct, given that
9450 the allowable indices are LOW..HIGH. Record the indices assigned
9451 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 9452 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9453static void
9454aggregate_assign_from_choices (struct value *container,
9455 struct value *lhs, struct expression *exp,
9456 int *pos, LONGEST *indices, int *num_indices,
9457 int max_indices, LONGEST low, LONGEST high)
9458{
9459 int j;
9460 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9461 int choice_pos, expr_pc;
9462 int is_array = ada_is_direct_array_type (value_type (lhs));
9463
9464 choice_pos = *pos += 3;
9465
9466 for (j = 0; j < n_choices; j += 1)
9467 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9468 expr_pc = *pos;
9469 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9470
9471 for (j = 0; j < n_choices; j += 1)
9472 {
9473 LONGEST lower, upper;
9474 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 9475
52ce6436
PH
9476 if (op == OP_DISCRETE_RANGE)
9477 {
9478 choice_pos += 1;
9479 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9480 EVAL_NORMAL));
9481 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9482 EVAL_NORMAL));
9483 }
9484 else if (is_array)
9485 {
9486 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9487 EVAL_NORMAL));
9488 upper = lower;
9489 }
9490 else
9491 {
9492 int ind;
0d5cff50 9493 const char *name;
5b4ee69b 9494
52ce6436
PH
9495 switch (op)
9496 {
9497 case OP_NAME:
9498 name = &exp->elts[choice_pos + 2].string;
9499 break;
9500 case OP_VAR_VALUE:
9501 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9502 break;
9503 default:
9504 error (_("Invalid record component association."));
9505 }
9506 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9507 ind = 0;
9508 if (! find_struct_field (name, value_type (lhs), 0,
9509 NULL, NULL, NULL, NULL, &ind))
9510 error (_("Unknown component name: %s."), name);
9511 lower = upper = ind;
9512 }
9513
9514 if (lower <= upper && (lower < low || upper > high))
9515 error (_("Index in component association out of bounds."));
9516
9517 add_component_interval (lower, upper, indices, num_indices,
9518 max_indices);
9519 while (lower <= upper)
9520 {
9521 int pos1;
5b4ee69b 9522
52ce6436
PH
9523 pos1 = expr_pc;
9524 assign_component (container, lhs, lower, exp, &pos1);
9525 lower += 1;
9526 }
9527 }
9528}
9529
9530/* Assign the value of the expression in the OP_OTHERS construct in
9531 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9532 have not been previously assigned. The index intervals already assigned
9533 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 9534 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9535static void
9536aggregate_assign_others (struct value *container,
9537 struct value *lhs, struct expression *exp,
9538 int *pos, LONGEST *indices, int num_indices,
9539 LONGEST low, LONGEST high)
9540{
9541 int i;
5ce64950 9542 int expr_pc = *pos + 1;
52ce6436
PH
9543
9544 for (i = 0; i < num_indices - 2; i += 2)
9545 {
9546 LONGEST ind;
5b4ee69b 9547
52ce6436
PH
9548 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9549 {
5ce64950 9550 int localpos;
5b4ee69b 9551
5ce64950
MS
9552 localpos = expr_pc;
9553 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
9554 }
9555 }
9556 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9557}
9558
9559/* Add the interval [LOW .. HIGH] to the sorted set of intervals
9560 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9561 modifying *SIZE as needed. It is an error if *SIZE exceeds
9562 MAX_SIZE. The resulting intervals do not overlap. */
9563static void
9564add_component_interval (LONGEST low, LONGEST high,
9565 LONGEST* indices, int *size, int max_size)
9566{
9567 int i, j;
5b4ee69b 9568
52ce6436
PH
9569 for (i = 0; i < *size; i += 2) {
9570 if (high >= indices[i] && low <= indices[i + 1])
9571 {
9572 int kh;
5b4ee69b 9573
52ce6436
PH
9574 for (kh = i + 2; kh < *size; kh += 2)
9575 if (high < indices[kh])
9576 break;
9577 if (low < indices[i])
9578 indices[i] = low;
9579 indices[i + 1] = indices[kh - 1];
9580 if (high > indices[i + 1])
9581 indices[i + 1] = high;
9582 memcpy (indices + i + 2, indices + kh, *size - kh);
9583 *size -= kh - i - 2;
9584 return;
9585 }
9586 else if (high < indices[i])
9587 break;
9588 }
9589
9590 if (*size == max_size)
9591 error (_("Internal error: miscounted aggregate components."));
9592 *size += 2;
9593 for (j = *size-1; j >= i+2; j -= 1)
9594 indices[j] = indices[j - 2];
9595 indices[i] = low;
9596 indices[i + 1] = high;
9597}
9598
6e48bd2c
JB
9599/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9600 is different. */
9601
9602static struct value *
9603ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
9604{
9605 if (type == ada_check_typedef (value_type (arg2)))
9606 return arg2;
9607
9608 if (ada_is_fixed_point_type (type))
9609 return (cast_to_fixed (type, arg2));
9610
9611 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9612 return cast_from_fixed (type, arg2);
6e48bd2c
JB
9613
9614 return value_cast (type, arg2);
9615}
9616
284614f0
JB
9617/* Evaluating Ada expressions, and printing their result.
9618 ------------------------------------------------------
9619
21649b50
JB
9620 1. Introduction:
9621 ----------------
9622
284614f0
JB
9623 We usually evaluate an Ada expression in order to print its value.
9624 We also evaluate an expression in order to print its type, which
9625 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9626 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9627 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9628 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9629 similar.
9630
9631 Evaluating expressions is a little more complicated for Ada entities
9632 than it is for entities in languages such as C. The main reason for
9633 this is that Ada provides types whose definition might be dynamic.
9634 One example of such types is variant records. Or another example
9635 would be an array whose bounds can only be known at run time.
9636
9637 The following description is a general guide as to what should be
9638 done (and what should NOT be done) in order to evaluate an expression
9639 involving such types, and when. This does not cover how the semantic
9640 information is encoded by GNAT as this is covered separatly. For the
9641 document used as the reference for the GNAT encoding, see exp_dbug.ads
9642 in the GNAT sources.
9643
9644 Ideally, we should embed each part of this description next to its
9645 associated code. Unfortunately, the amount of code is so vast right
9646 now that it's hard to see whether the code handling a particular
9647 situation might be duplicated or not. One day, when the code is
9648 cleaned up, this guide might become redundant with the comments
9649 inserted in the code, and we might want to remove it.
9650
21649b50
JB
9651 2. ``Fixing'' an Entity, the Simple Case:
9652 -----------------------------------------
9653
284614f0
JB
9654 When evaluating Ada expressions, the tricky issue is that they may
9655 reference entities whose type contents and size are not statically
9656 known. Consider for instance a variant record:
9657
9658 type Rec (Empty : Boolean := True) is record
9659 case Empty is
9660 when True => null;
9661 when False => Value : Integer;
9662 end case;
9663 end record;
9664 Yes : Rec := (Empty => False, Value => 1);
9665 No : Rec := (empty => True);
9666
9667 The size and contents of that record depends on the value of the
9668 descriminant (Rec.Empty). At this point, neither the debugging
9669 information nor the associated type structure in GDB are able to
9670 express such dynamic types. So what the debugger does is to create
9671 "fixed" versions of the type that applies to the specific object.
9672 We also informally refer to this opperation as "fixing" an object,
9673 which means creating its associated fixed type.
9674
9675 Example: when printing the value of variable "Yes" above, its fixed
9676 type would look like this:
9677
9678 type Rec is record
9679 Empty : Boolean;
9680 Value : Integer;
9681 end record;
9682
9683 On the other hand, if we printed the value of "No", its fixed type
9684 would become:
9685
9686 type Rec is record
9687 Empty : Boolean;
9688 end record;
9689
9690 Things become a little more complicated when trying to fix an entity
9691 with a dynamic type that directly contains another dynamic type,
9692 such as an array of variant records, for instance. There are
9693 two possible cases: Arrays, and records.
9694
21649b50
JB
9695 3. ``Fixing'' Arrays:
9696 ---------------------
9697
9698 The type structure in GDB describes an array in terms of its bounds,
9699 and the type of its elements. By design, all elements in the array
9700 have the same type and we cannot represent an array of variant elements
9701 using the current type structure in GDB. When fixing an array,
9702 we cannot fix the array element, as we would potentially need one
9703 fixed type per element of the array. As a result, the best we can do
9704 when fixing an array is to produce an array whose bounds and size
9705 are correct (allowing us to read it from memory), but without having
9706 touched its element type. Fixing each element will be done later,
9707 when (if) necessary.
9708
9709 Arrays are a little simpler to handle than records, because the same
9710 amount of memory is allocated for each element of the array, even if
1b536f04 9711 the amount of space actually used by each element differs from element
21649b50 9712 to element. Consider for instance the following array of type Rec:
284614f0
JB
9713
9714 type Rec_Array is array (1 .. 2) of Rec;
9715
1b536f04
JB
9716 The actual amount of memory occupied by each element might be different
9717 from element to element, depending on the value of their discriminant.
21649b50 9718 But the amount of space reserved for each element in the array remains
1b536f04 9719 fixed regardless. So we simply need to compute that size using
21649b50
JB
9720 the debugging information available, from which we can then determine
9721 the array size (we multiply the number of elements of the array by
9722 the size of each element).
9723
9724 The simplest case is when we have an array of a constrained element
9725 type. For instance, consider the following type declarations:
9726
9727 type Bounded_String (Max_Size : Integer) is
9728 Length : Integer;
9729 Buffer : String (1 .. Max_Size);
9730 end record;
9731 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9732
9733 In this case, the compiler describes the array as an array of
9734 variable-size elements (identified by its XVS suffix) for which
9735 the size can be read in the parallel XVZ variable.
9736
9737 In the case of an array of an unconstrained element type, the compiler
9738 wraps the array element inside a private PAD type. This type should not
9739 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
9740 that we also use the adjective "aligner" in our code to designate
9741 these wrapper types.
9742
1b536f04 9743 In some cases, the size allocated for each element is statically
21649b50
JB
9744 known. In that case, the PAD type already has the correct size,
9745 and the array element should remain unfixed.
9746
9747 But there are cases when this size is not statically known.
9748 For instance, assuming that "Five" is an integer variable:
284614f0
JB
9749
9750 type Dynamic is array (1 .. Five) of Integer;
9751 type Wrapper (Has_Length : Boolean := False) is record
9752 Data : Dynamic;
9753 case Has_Length is
9754 when True => Length : Integer;
9755 when False => null;
9756 end case;
9757 end record;
9758 type Wrapper_Array is array (1 .. 2) of Wrapper;
9759
9760 Hello : Wrapper_Array := (others => (Has_Length => True,
9761 Data => (others => 17),
9762 Length => 1));
9763
9764
9765 The debugging info would describe variable Hello as being an
9766 array of a PAD type. The size of that PAD type is not statically
9767 known, but can be determined using a parallel XVZ variable.
9768 In that case, a copy of the PAD type with the correct size should
9769 be used for the fixed array.
9770
21649b50
JB
9771 3. ``Fixing'' record type objects:
9772 ----------------------------------
9773
9774 Things are slightly different from arrays in the case of dynamic
284614f0
JB
9775 record types. In this case, in order to compute the associated
9776 fixed type, we need to determine the size and offset of each of
9777 its components. This, in turn, requires us to compute the fixed
9778 type of each of these components.
9779
9780 Consider for instance the example:
9781
9782 type Bounded_String (Max_Size : Natural) is record
9783 Str : String (1 .. Max_Size);
9784 Length : Natural;
9785 end record;
9786 My_String : Bounded_String (Max_Size => 10);
9787
9788 In that case, the position of field "Length" depends on the size
9789 of field Str, which itself depends on the value of the Max_Size
21649b50 9790 discriminant. In order to fix the type of variable My_String,
284614f0
JB
9791 we need to fix the type of field Str. Therefore, fixing a variant
9792 record requires us to fix each of its components.
9793
9794 However, if a component does not have a dynamic size, the component
9795 should not be fixed. In particular, fields that use a PAD type
9796 should not fixed. Here is an example where this might happen
9797 (assuming type Rec above):
9798
9799 type Container (Big : Boolean) is record
9800 First : Rec;
9801 After : Integer;
9802 case Big is
9803 when True => Another : Integer;
9804 when False => null;
9805 end case;
9806 end record;
9807 My_Container : Container := (Big => False,
9808 First => (Empty => True),
9809 After => 42);
9810
9811 In that example, the compiler creates a PAD type for component First,
9812 whose size is constant, and then positions the component After just
9813 right after it. The offset of component After is therefore constant
9814 in this case.
9815
9816 The debugger computes the position of each field based on an algorithm
9817 that uses, among other things, the actual position and size of the field
21649b50
JB
9818 preceding it. Let's now imagine that the user is trying to print
9819 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
9820 end up computing the offset of field After based on the size of the
9821 fixed version of field First. And since in our example First has
9822 only one actual field, the size of the fixed type is actually smaller
9823 than the amount of space allocated to that field, and thus we would
9824 compute the wrong offset of field After.
9825
21649b50
JB
9826 To make things more complicated, we need to watch out for dynamic
9827 components of variant records (identified by the ___XVL suffix in
9828 the component name). Even if the target type is a PAD type, the size
9829 of that type might not be statically known. So the PAD type needs
9830 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9831 we might end up with the wrong size for our component. This can be
9832 observed with the following type declarations:
284614f0
JB
9833
9834 type Octal is new Integer range 0 .. 7;
9835 type Octal_Array is array (Positive range <>) of Octal;
9836 pragma Pack (Octal_Array);
9837
9838 type Octal_Buffer (Size : Positive) is record
9839 Buffer : Octal_Array (1 .. Size);
9840 Length : Integer;
9841 end record;
9842
9843 In that case, Buffer is a PAD type whose size is unset and needs
9844 to be computed by fixing the unwrapped type.
9845
21649b50
JB
9846 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9847 ----------------------------------------------------------
9848
9849 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
9850 thus far, be actually fixed?
9851
9852 The answer is: Only when referencing that element. For instance
9853 when selecting one component of a record, this specific component
9854 should be fixed at that point in time. Or when printing the value
9855 of a record, each component should be fixed before its value gets
9856 printed. Similarly for arrays, the element of the array should be
9857 fixed when printing each element of the array, or when extracting
9858 one element out of that array. On the other hand, fixing should
9859 not be performed on the elements when taking a slice of an array!
9860
9861 Note that one of the side-effects of miscomputing the offset and
9862 size of each field is that we end up also miscomputing the size
9863 of the containing type. This can have adverse results when computing
9864 the value of an entity. GDB fetches the value of an entity based
9865 on the size of its type, and thus a wrong size causes GDB to fetch
9866 the wrong amount of memory. In the case where the computed size is
9867 too small, GDB fetches too little data to print the value of our
9868 entiry. Results in this case as unpredicatble, as we usually read
9869 past the buffer containing the data =:-o. */
9870
9871/* Implement the evaluate_exp routine in the exp_descriptor structure
9872 for the Ada language. */
9873
52ce6436 9874static struct value *
ebf56fd3 9875ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 9876 int *pos, enum noside noside)
14f9c5c9
AS
9877{
9878 enum exp_opcode op;
b5385fc0 9879 int tem;
14f9c5c9
AS
9880 int pc;
9881 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
9882 struct type *type;
52ce6436 9883 int nargs, oplen;
d2e4a39e 9884 struct value **argvec;
14f9c5c9 9885
d2e4a39e
AS
9886 pc = *pos;
9887 *pos += 1;
14f9c5c9
AS
9888 op = exp->elts[pc].opcode;
9889
d2e4a39e 9890 switch (op)
14f9c5c9
AS
9891 {
9892 default:
9893 *pos -= 1;
6e48bd2c 9894 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
9895
9896 if (noside == EVAL_NORMAL)
9897 arg1 = unwrap_value (arg1);
6e48bd2c
JB
9898
9899 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
9900 then we need to perform the conversion manually, because
9901 evaluate_subexp_standard doesn't do it. This conversion is
9902 necessary in Ada because the different kinds of float/fixed
9903 types in Ada have different representations.
9904
9905 Similarly, we need to perform the conversion from OP_LONG
9906 ourselves. */
9907 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
9908 arg1 = ada_value_cast (expect_type, arg1, noside);
9909
9910 return arg1;
4c4b4cd2
PH
9911
9912 case OP_STRING:
9913 {
76a01679 9914 struct value *result;
5b4ee69b 9915
76a01679
JB
9916 *pos -= 1;
9917 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
9918 /* The result type will have code OP_STRING, bashed there from
9919 OP_ARRAY. Bash it back. */
df407dfe
AC
9920 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
9921 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 9922 return result;
4c4b4cd2 9923 }
14f9c5c9
AS
9924
9925 case UNOP_CAST:
9926 (*pos) += 2;
9927 type = exp->elts[pc + 1].type;
9928 arg1 = evaluate_subexp (type, exp, pos, noside);
9929 if (noside == EVAL_SKIP)
4c4b4cd2 9930 goto nosideret;
6e48bd2c 9931 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
9932 return arg1;
9933
4c4b4cd2
PH
9934 case UNOP_QUAL:
9935 (*pos) += 2;
9936 type = exp->elts[pc + 1].type;
9937 return ada_evaluate_subexp (type, exp, pos, noside);
9938
14f9c5c9
AS
9939 case BINOP_ASSIGN:
9940 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
9941 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9942 {
9943 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
9944 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
9945 return arg1;
9946 return ada_value_assign (arg1, arg1);
9947 }
003f3813
JB
9948 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9949 except if the lhs of our assignment is a convenience variable.
9950 In the case of assigning to a convenience variable, the lhs
9951 should be exactly the result of the evaluation of the rhs. */
9952 type = value_type (arg1);
9953 if (VALUE_LVAL (arg1) == lval_internalvar)
9954 type = NULL;
9955 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 9956 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 9957 return arg1;
df407dfe
AC
9958 if (ada_is_fixed_point_type (value_type (arg1)))
9959 arg2 = cast_to_fixed (value_type (arg1), arg2);
9960 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 9961 error
323e0a4a 9962 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 9963 else
df407dfe 9964 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 9965 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
9966
9967 case BINOP_ADD:
9968 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9969 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9970 if (noside == EVAL_SKIP)
4c4b4cd2 9971 goto nosideret;
2ac8a782
JB
9972 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9973 return (value_from_longest
9974 (value_type (arg1),
9975 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
9976 if ((ada_is_fixed_point_type (value_type (arg1))
9977 || ada_is_fixed_point_type (value_type (arg2)))
9978 && value_type (arg1) != value_type (arg2))
323e0a4a 9979 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
9980 /* Do the addition, and cast the result to the type of the first
9981 argument. We cannot cast the result to a reference type, so if
9982 ARG1 is a reference type, find its underlying type. */
9983 type = value_type (arg1);
9984 while (TYPE_CODE (type) == TYPE_CODE_REF)
9985 type = TYPE_TARGET_TYPE (type);
f44316fa 9986 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 9987 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
9988
9989 case BINOP_SUB:
9990 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9991 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9992 if (noside == EVAL_SKIP)
4c4b4cd2 9993 goto nosideret;
2ac8a782
JB
9994 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9995 return (value_from_longest
9996 (value_type (arg1),
9997 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
9998 if ((ada_is_fixed_point_type (value_type (arg1))
9999 || ada_is_fixed_point_type (value_type (arg2)))
10000 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10001 error (_("Operands of fixed-point subtraction "
10002 "must have the same type"));
b7789565
JB
10003 /* Do the substraction, and cast the result to the type of the first
10004 argument. We cannot cast the result to a reference type, so if
10005 ARG1 is a reference type, find its underlying type. */
10006 type = value_type (arg1);
10007 while (TYPE_CODE (type) == TYPE_CODE_REF)
10008 type = TYPE_TARGET_TYPE (type);
f44316fa 10009 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10010 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10011
10012 case BINOP_MUL:
10013 case BINOP_DIV:
e1578042
JB
10014 case BINOP_REM:
10015 case BINOP_MOD:
14f9c5c9
AS
10016 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10017 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10018 if (noside == EVAL_SKIP)
4c4b4cd2 10019 goto nosideret;
e1578042 10020 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10021 {
10022 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10023 return value_zero (value_type (arg1), not_lval);
10024 }
14f9c5c9 10025 else
4c4b4cd2 10026 {
a53b7a21 10027 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10028 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10029 arg1 = cast_from_fixed (type, arg1);
df407dfe 10030 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10031 arg2 = cast_from_fixed (type, arg2);
f44316fa 10032 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10033 return ada_value_binop (arg1, arg2, op);
10034 }
10035
4c4b4cd2
PH
10036 case BINOP_EQUAL:
10037 case BINOP_NOTEQUAL:
14f9c5c9 10038 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10039 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10040 if (noside == EVAL_SKIP)
76a01679 10041 goto nosideret;
4c4b4cd2 10042 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10043 tem = 0;
4c4b4cd2 10044 else
f44316fa
UW
10045 {
10046 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10047 tem = ada_value_equal (arg1, arg2);
10048 }
4c4b4cd2 10049 if (op == BINOP_NOTEQUAL)
76a01679 10050 tem = !tem;
fbb06eb1
UW
10051 type = language_bool_type (exp->language_defn, exp->gdbarch);
10052 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10053
10054 case UNOP_NEG:
10055 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10056 if (noside == EVAL_SKIP)
10057 goto nosideret;
df407dfe
AC
10058 else if (ada_is_fixed_point_type (value_type (arg1)))
10059 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10060 else
f44316fa
UW
10061 {
10062 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10063 return value_neg (arg1);
10064 }
4c4b4cd2 10065
2330c6c6
JB
10066 case BINOP_LOGICAL_AND:
10067 case BINOP_LOGICAL_OR:
10068 case UNOP_LOGICAL_NOT:
000d5124
JB
10069 {
10070 struct value *val;
10071
10072 *pos -= 1;
10073 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10074 type = language_bool_type (exp->language_defn, exp->gdbarch);
10075 return value_cast (type, val);
000d5124 10076 }
2330c6c6
JB
10077
10078 case BINOP_BITWISE_AND:
10079 case BINOP_BITWISE_IOR:
10080 case BINOP_BITWISE_XOR:
000d5124
JB
10081 {
10082 struct value *val;
10083
10084 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10085 *pos = pc;
10086 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10087
10088 return value_cast (value_type (arg1), val);
10089 }
2330c6c6 10090
14f9c5c9
AS
10091 case OP_VAR_VALUE:
10092 *pos -= 1;
6799def4 10093
14f9c5c9 10094 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10095 {
10096 *pos += 4;
10097 goto nosideret;
10098 }
10099 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10100 /* Only encountered when an unresolved symbol occurs in a
10101 context other than a function call, in which case, it is
52ce6436 10102 invalid. */
323e0a4a 10103 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10104 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
14f9c5c9 10105 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10106 {
0c1f74cf 10107 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10108 /* Check to see if this is a tagged type. We also need to handle
10109 the case where the type is a reference to a tagged type, but
10110 we have to be careful to exclude pointers to tagged types.
10111 The latter should be shown as usual (as a pointer), whereas
10112 a reference should mostly be transparent to the user. */
10113 if (ada_is_tagged_type (type, 0)
10114 || (TYPE_CODE(type) == TYPE_CODE_REF
10115 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0c1f74cf
JB
10116 {
10117 /* Tagged types are a little special in the fact that the real
10118 type is dynamic and can only be determined by inspecting the
10119 object's tag. This means that we need to get the object's
10120 value first (EVAL_NORMAL) and then extract the actual object
10121 type from its tag.
10122
10123 Note that we cannot skip the final step where we extract
10124 the object type from its tag, because the EVAL_NORMAL phase
10125 results in dynamic components being resolved into fixed ones.
10126 This can cause problems when trying to print the type
10127 description of tagged types whose parent has a dynamic size:
10128 We use the type name of the "_parent" component in order
10129 to print the name of the ancestor type in the type description.
10130 If that component had a dynamic size, the resolution into
10131 a fixed type would result in the loss of that type name,
10132 thus preventing us from printing the name of the ancestor
10133 type in the type description. */
10134 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
b50d69b5
JG
10135
10136 if (TYPE_CODE (type) != TYPE_CODE_REF)
10137 {
10138 struct type *actual_type;
10139
10140 actual_type = type_from_tag (ada_value_tag (arg1));
10141 if (actual_type == NULL)
10142 /* If, for some reason, we were unable to determine
10143 the actual type from the tag, then use the static
10144 approximation that we just computed as a fallback.
10145 This can happen if the debugging information is
10146 incomplete, for instance. */
10147 actual_type = type;
10148 return value_zero (actual_type, not_lval);
10149 }
10150 else
10151 {
10152 /* In the case of a ref, ada_coerce_ref takes care
10153 of determining the actual type. But the evaluation
10154 should return a ref as it should be valid to ask
10155 for its address; so rebuild a ref after coerce. */
10156 arg1 = ada_coerce_ref (arg1);
10157 return value_ref (arg1);
10158 }
0c1f74cf
JB
10159 }
10160
4c4b4cd2
PH
10161 *pos += 4;
10162 return value_zero
10163 (to_static_fixed_type
10164 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
10165 not_lval);
10166 }
d2e4a39e 10167 else
4c4b4cd2 10168 {
284614f0 10169 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
4c4b4cd2
PH
10170 return ada_to_fixed_value (arg1);
10171 }
10172
10173 case OP_FUNCALL:
10174 (*pos) += 2;
10175
10176 /* Allocate arg vector, including space for the function to be
10177 called in argvec[0] and a terminating NULL. */
10178 nargs = longest_to_int (exp->elts[pc + 1].longconst);
10179 argvec =
10180 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
10181
10182 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10183 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10184 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10185 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10186 else
10187 {
10188 for (tem = 0; tem <= nargs; tem += 1)
10189 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10190 argvec[tem] = 0;
10191
10192 if (noside == EVAL_SKIP)
10193 goto nosideret;
10194 }
10195
ad82864c
JB
10196 if (ada_is_constrained_packed_array_type
10197 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10198 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10199 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10200 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10201 /* This is a packed array that has already been fixed, and
10202 therefore already coerced to a simple array. Nothing further
10203 to do. */
10204 ;
df407dfe
AC
10205 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
10206 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
76a01679 10207 && VALUE_LVAL (argvec[0]) == lval_memory))
4c4b4cd2
PH
10208 argvec[0] = value_addr (argvec[0]);
10209
df407dfe 10210 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10211
10212 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10213 them. So, if this is an array typedef (encoding use for array
10214 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10215 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10216 type = ada_typedef_target_type (type);
10217
4c4b4cd2
PH
10218 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10219 {
61ee279c 10220 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10221 {
10222 case TYPE_CODE_FUNC:
61ee279c 10223 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10224 break;
10225 case TYPE_CODE_ARRAY:
10226 break;
10227 case TYPE_CODE_STRUCT:
10228 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10229 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10230 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10231 break;
10232 default:
323e0a4a 10233 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10234 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10235 break;
10236 }
10237 }
10238
10239 switch (TYPE_CODE (type))
10240 {
10241 case TYPE_CODE_FUNC:
10242 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972
PH
10243 {
10244 struct type *rtype = TYPE_TARGET_TYPE (type);
10245
10246 if (TYPE_GNU_IFUNC (type))
10247 return allocate_value (TYPE_TARGET_TYPE (rtype));
10248 return allocate_value (rtype);
10249 }
4c4b4cd2 10250 return call_function_by_hand (argvec[0], nargs, argvec + 1);
c8ea1972
PH
10251 case TYPE_CODE_INTERNAL_FUNCTION:
10252 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10253 /* We don't know anything about what the internal
10254 function might return, but we have to return
10255 something. */
10256 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10257 not_lval);
10258 else
10259 return call_internal_function (exp->gdbarch, exp->language_defn,
10260 argvec[0], nargs, argvec + 1);
10261
4c4b4cd2
PH
10262 case TYPE_CODE_STRUCT:
10263 {
10264 int arity;
10265
4c4b4cd2
PH
10266 arity = ada_array_arity (type);
10267 type = ada_array_element_type (type, nargs);
10268 if (type == NULL)
323e0a4a 10269 error (_("cannot subscript or call a record"));
4c4b4cd2 10270 if (arity != nargs)
323e0a4a 10271 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10272 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10273 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10274 return
10275 unwrap_value (ada_value_subscript
10276 (argvec[0], nargs, argvec + 1));
10277 }
10278 case TYPE_CODE_ARRAY:
10279 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10280 {
10281 type = ada_array_element_type (type, nargs);
10282 if (type == NULL)
323e0a4a 10283 error (_("element type of array unknown"));
4c4b4cd2 10284 else
0a07e705 10285 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10286 }
10287 return
10288 unwrap_value (ada_value_subscript
10289 (ada_coerce_to_simple_array (argvec[0]),
10290 nargs, argvec + 1));
10291 case TYPE_CODE_PTR: /* Pointer to array */
10292 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10293 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10294 {
10295 type = ada_array_element_type (type, nargs);
10296 if (type == NULL)
323e0a4a 10297 error (_("element type of array unknown"));
4c4b4cd2 10298 else
0a07e705 10299 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10300 }
10301 return
10302 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
10303 nargs, argvec + 1));
10304
10305 default:
e1d5a0d2
PH
10306 error (_("Attempt to index or call something other than an "
10307 "array or function"));
4c4b4cd2
PH
10308 }
10309
10310 case TERNOP_SLICE:
10311 {
10312 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10313 struct value *low_bound_val =
10314 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
10315 struct value *high_bound_val =
10316 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10317 LONGEST low_bound;
10318 LONGEST high_bound;
5b4ee69b 10319
994b9211
AC
10320 low_bound_val = coerce_ref (low_bound_val);
10321 high_bound_val = coerce_ref (high_bound_val);
714e53ab
PH
10322 low_bound = pos_atr (low_bound_val);
10323 high_bound = pos_atr (high_bound_val);
963a6417 10324
4c4b4cd2
PH
10325 if (noside == EVAL_SKIP)
10326 goto nosideret;
10327
4c4b4cd2
PH
10328 /* If this is a reference to an aligner type, then remove all
10329 the aligners. */
df407dfe
AC
10330 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10331 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10332 TYPE_TARGET_TYPE (value_type (array)) =
10333 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 10334
ad82864c 10335 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 10336 error (_("cannot slice a packed array"));
4c4b4cd2
PH
10337
10338 /* If this is a reference to an array or an array lvalue,
10339 convert to a pointer. */
df407dfe
AC
10340 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10341 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
10342 && VALUE_LVAL (array) == lval_memory))
10343 array = value_addr (array);
10344
1265e4aa 10345 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 10346 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 10347 (value_type (array))))
0b5d8877 10348 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
10349
10350 array = ada_coerce_to_simple_array_ptr (array);
10351
714e53ab
PH
10352 /* If we have more than one level of pointer indirection,
10353 dereference the value until we get only one level. */
df407dfe
AC
10354 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10355 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
10356 == TYPE_CODE_PTR))
10357 array = value_ind (array);
10358
10359 /* Make sure we really do have an array type before going further,
10360 to avoid a SEGV when trying to get the index type or the target
10361 type later down the road if the debug info generated by
10362 the compiler is incorrect or incomplete. */
df407dfe 10363 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 10364 error (_("cannot take slice of non-array"));
714e53ab 10365
828292f2
JB
10366 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10367 == TYPE_CODE_PTR)
4c4b4cd2 10368 {
828292f2
JB
10369 struct type *type0 = ada_check_typedef (value_type (array));
10370
0b5d8877 10371 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 10372 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
10373 else
10374 {
10375 struct type *arr_type0 =
828292f2 10376 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 10377
f5938064
JG
10378 return ada_value_slice_from_ptr (array, arr_type0,
10379 longest_to_int (low_bound),
10380 longest_to_int (high_bound));
4c4b4cd2
PH
10381 }
10382 }
10383 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10384 return array;
10385 else if (high_bound < low_bound)
df407dfe 10386 return empty_array (value_type (array), low_bound);
4c4b4cd2 10387 else
529cad9c
PH
10388 return ada_value_slice (array, longest_to_int (low_bound),
10389 longest_to_int (high_bound));
4c4b4cd2 10390 }
14f9c5c9 10391
4c4b4cd2
PH
10392 case UNOP_IN_RANGE:
10393 (*pos) += 2;
10394 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 10395 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 10396
14f9c5c9 10397 if (noside == EVAL_SKIP)
4c4b4cd2 10398 goto nosideret;
14f9c5c9 10399
4c4b4cd2
PH
10400 switch (TYPE_CODE (type))
10401 {
10402 default:
e1d5a0d2
PH
10403 lim_warning (_("Membership test incompletely implemented; "
10404 "always returns true"));
fbb06eb1
UW
10405 type = language_bool_type (exp->language_defn, exp->gdbarch);
10406 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
10407
10408 case TYPE_CODE_RANGE:
030b4912
UW
10409 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10410 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
10411 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10412 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
10413 type = language_bool_type (exp->language_defn, exp->gdbarch);
10414 return
10415 value_from_longest (type,
4c4b4cd2
PH
10416 (value_less (arg1, arg3)
10417 || value_equal (arg1, arg3))
10418 && (value_less (arg2, arg1)
10419 || value_equal (arg2, arg1)));
10420 }
10421
10422 case BINOP_IN_BOUNDS:
14f9c5c9 10423 (*pos) += 2;
4c4b4cd2
PH
10424 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10425 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10426
4c4b4cd2
PH
10427 if (noside == EVAL_SKIP)
10428 goto nosideret;
14f9c5c9 10429
4c4b4cd2 10430 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
10431 {
10432 type = language_bool_type (exp->language_defn, exp->gdbarch);
10433 return value_zero (type, not_lval);
10434 }
14f9c5c9 10435
4c4b4cd2 10436 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 10437
1eea4ebd
UW
10438 type = ada_index_type (value_type (arg2), tem, "range");
10439 if (!type)
10440 type = value_type (arg1);
14f9c5c9 10441
1eea4ebd
UW
10442 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10443 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 10444
f44316fa
UW
10445 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10446 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10447 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10448 return
fbb06eb1 10449 value_from_longest (type,
4c4b4cd2
PH
10450 (value_less (arg1, arg3)
10451 || value_equal (arg1, arg3))
10452 && (value_less (arg2, arg1)
10453 || value_equal (arg2, arg1)));
10454
10455 case TERNOP_IN_RANGE:
10456 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10457 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10458 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10459
10460 if (noside == EVAL_SKIP)
10461 goto nosideret;
10462
f44316fa
UW
10463 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10464 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10465 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10466 return
fbb06eb1 10467 value_from_longest (type,
4c4b4cd2
PH
10468 (value_less (arg1, arg3)
10469 || value_equal (arg1, arg3))
10470 && (value_less (arg2, arg1)
10471 || value_equal (arg2, arg1)));
10472
10473 case OP_ATR_FIRST:
10474 case OP_ATR_LAST:
10475 case OP_ATR_LENGTH:
10476 {
76a01679 10477 struct type *type_arg;
5b4ee69b 10478
76a01679
JB
10479 if (exp->elts[*pos].opcode == OP_TYPE)
10480 {
10481 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10482 arg1 = NULL;
5bc23cb3 10483 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
10484 }
10485 else
10486 {
10487 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10488 type_arg = NULL;
10489 }
10490
10491 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 10492 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
10493 tem = longest_to_int (exp->elts[*pos + 2].longconst);
10494 *pos += 4;
10495
10496 if (noside == EVAL_SKIP)
10497 goto nosideret;
10498
10499 if (type_arg == NULL)
10500 {
10501 arg1 = ada_coerce_ref (arg1);
10502
ad82864c 10503 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
10504 arg1 = ada_coerce_to_simple_array (arg1);
10505
aa4fb036 10506 if (op == OP_ATR_LENGTH)
1eea4ebd 10507 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
10508 else
10509 {
10510 type = ada_index_type (value_type (arg1), tem,
10511 ada_attribute_name (op));
10512 if (type == NULL)
10513 type = builtin_type (exp->gdbarch)->builtin_int;
10514 }
76a01679
JB
10515
10516 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 10517 return allocate_value (type);
76a01679
JB
10518
10519 switch (op)
10520 {
10521 default: /* Should never happen. */
323e0a4a 10522 error (_("unexpected attribute encountered"));
76a01679 10523 case OP_ATR_FIRST:
1eea4ebd
UW
10524 return value_from_longest
10525 (type, ada_array_bound (arg1, tem, 0));
76a01679 10526 case OP_ATR_LAST:
1eea4ebd
UW
10527 return value_from_longest
10528 (type, ada_array_bound (arg1, tem, 1));
76a01679 10529 case OP_ATR_LENGTH:
1eea4ebd
UW
10530 return value_from_longest
10531 (type, ada_array_length (arg1, tem));
76a01679
JB
10532 }
10533 }
10534 else if (discrete_type_p (type_arg))
10535 {
10536 struct type *range_type;
0d5cff50 10537 const char *name = ada_type_name (type_arg);
5b4ee69b 10538
76a01679
JB
10539 range_type = NULL;
10540 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 10541 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
10542 if (range_type == NULL)
10543 range_type = type_arg;
10544 switch (op)
10545 {
10546 default:
323e0a4a 10547 error (_("unexpected attribute encountered"));
76a01679 10548 case OP_ATR_FIRST:
690cc4eb 10549 return value_from_longest
43bbcdc2 10550 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 10551 case OP_ATR_LAST:
690cc4eb 10552 return value_from_longest
43bbcdc2 10553 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 10554 case OP_ATR_LENGTH:
323e0a4a 10555 error (_("the 'length attribute applies only to array types"));
76a01679
JB
10556 }
10557 }
10558 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 10559 error (_("unimplemented type attribute"));
76a01679
JB
10560 else
10561 {
10562 LONGEST low, high;
10563
ad82864c
JB
10564 if (ada_is_constrained_packed_array_type (type_arg))
10565 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 10566
aa4fb036 10567 if (op == OP_ATR_LENGTH)
1eea4ebd 10568 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
10569 else
10570 {
10571 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10572 if (type == NULL)
10573 type = builtin_type (exp->gdbarch)->builtin_int;
10574 }
1eea4ebd 10575
76a01679
JB
10576 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10577 return allocate_value (type);
10578
10579 switch (op)
10580 {
10581 default:
323e0a4a 10582 error (_("unexpected attribute encountered"));
76a01679 10583 case OP_ATR_FIRST:
1eea4ebd 10584 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
10585 return value_from_longest (type, low);
10586 case OP_ATR_LAST:
1eea4ebd 10587 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10588 return value_from_longest (type, high);
10589 case OP_ATR_LENGTH:
1eea4ebd
UW
10590 low = ada_array_bound_from_type (type_arg, tem, 0);
10591 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10592 return value_from_longest (type, high - low + 1);
10593 }
10594 }
14f9c5c9
AS
10595 }
10596
4c4b4cd2
PH
10597 case OP_ATR_TAG:
10598 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10599 if (noside == EVAL_SKIP)
76a01679 10600 goto nosideret;
4c4b4cd2
PH
10601
10602 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10603 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
10604
10605 return ada_value_tag (arg1);
10606
10607 case OP_ATR_MIN:
10608 case OP_ATR_MAX:
10609 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10610 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10611 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10612 if (noside == EVAL_SKIP)
76a01679 10613 goto nosideret;
d2e4a39e 10614 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10615 return value_zero (value_type (arg1), not_lval);
14f9c5c9 10616 else
f44316fa
UW
10617 {
10618 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10619 return value_binop (arg1, arg2,
10620 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
10621 }
14f9c5c9 10622
4c4b4cd2
PH
10623 case OP_ATR_MODULUS:
10624 {
31dedfee 10625 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 10626
5b4ee69b 10627 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
10628 if (noside == EVAL_SKIP)
10629 goto nosideret;
4c4b4cd2 10630
76a01679 10631 if (!ada_is_modular_type (type_arg))
323e0a4a 10632 error (_("'modulus must be applied to modular type"));
4c4b4cd2 10633
76a01679
JB
10634 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
10635 ada_modulus (type_arg));
4c4b4cd2
PH
10636 }
10637
10638
10639 case OP_ATR_POS:
10640 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10641 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10642 if (noside == EVAL_SKIP)
76a01679 10643 goto nosideret;
3cb382c9
UW
10644 type = builtin_type (exp->gdbarch)->builtin_int;
10645 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10646 return value_zero (type, not_lval);
14f9c5c9 10647 else
3cb382c9 10648 return value_pos_atr (type, arg1);
14f9c5c9 10649
4c4b4cd2
PH
10650 case OP_ATR_SIZE:
10651 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
10652 type = value_type (arg1);
10653
10654 /* If the argument is a reference, then dereference its type, since
10655 the user is really asking for the size of the actual object,
10656 not the size of the pointer. */
10657 if (TYPE_CODE (type) == TYPE_CODE_REF)
10658 type = TYPE_TARGET_TYPE (type);
10659
4c4b4cd2 10660 if (noside == EVAL_SKIP)
76a01679 10661 goto nosideret;
4c4b4cd2 10662 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 10663 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 10664 else
22601c15 10665 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 10666 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
10667
10668 case OP_ATR_VAL:
10669 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 10670 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 10671 type = exp->elts[pc + 2].type;
14f9c5c9 10672 if (noside == EVAL_SKIP)
76a01679 10673 goto nosideret;
4c4b4cd2 10674 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10675 return value_zero (type, not_lval);
4c4b4cd2 10676 else
76a01679 10677 return value_val_atr (type, arg1);
4c4b4cd2
PH
10678
10679 case BINOP_EXP:
10680 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10681 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10682 if (noside == EVAL_SKIP)
10683 goto nosideret;
10684 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10685 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 10686 else
f44316fa
UW
10687 {
10688 /* For integer exponentiation operations,
10689 only promote the first argument. */
10690 if (is_integral_type (value_type (arg2)))
10691 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10692 else
10693 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10694
10695 return value_binop (arg1, arg2, op);
10696 }
4c4b4cd2
PH
10697
10698 case UNOP_PLUS:
10699 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10700 if (noside == EVAL_SKIP)
10701 goto nosideret;
10702 else
10703 return arg1;
10704
10705 case UNOP_ABS:
10706 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10707 if (noside == EVAL_SKIP)
10708 goto nosideret;
f44316fa 10709 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 10710 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 10711 return value_neg (arg1);
14f9c5c9 10712 else
4c4b4cd2 10713 return arg1;
14f9c5c9
AS
10714
10715 case UNOP_IND:
6b0d7253 10716 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10717 if (noside == EVAL_SKIP)
4c4b4cd2 10718 goto nosideret;
df407dfe 10719 type = ada_check_typedef (value_type (arg1));
14f9c5c9 10720 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
10721 {
10722 if (ada_is_array_descriptor_type (type))
10723 /* GDB allows dereferencing GNAT array descriptors. */
10724 {
10725 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 10726
4c4b4cd2 10727 if (arrType == NULL)
323e0a4a 10728 error (_("Attempt to dereference null array pointer."));
00a4c844 10729 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
10730 }
10731 else if (TYPE_CODE (type) == TYPE_CODE_PTR
10732 || TYPE_CODE (type) == TYPE_CODE_REF
10733 /* In C you can dereference an array to get the 1st elt. */
10734 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab
PH
10735 {
10736 type = to_static_fixed_type
10737 (ada_aligned_type
10738 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10739 check_size (type);
10740 return value_zero (type, lval_memory);
10741 }
4c4b4cd2 10742 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
10743 {
10744 /* GDB allows dereferencing an int. */
10745 if (expect_type == NULL)
10746 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10747 lval_memory);
10748 else
10749 {
10750 expect_type =
10751 to_static_fixed_type (ada_aligned_type (expect_type));
10752 return value_zero (expect_type, lval_memory);
10753 }
10754 }
4c4b4cd2 10755 else
323e0a4a 10756 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 10757 }
0963b4bd 10758 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 10759 type = ada_check_typedef (value_type (arg1));
d2e4a39e 10760
96967637
JB
10761 if (TYPE_CODE (type) == TYPE_CODE_INT)
10762 /* GDB allows dereferencing an int. If we were given
10763 the expect_type, then use that as the target type.
10764 Otherwise, assume that the target type is an int. */
10765 {
10766 if (expect_type != NULL)
10767 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10768 arg1));
10769 else
10770 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10771 (CORE_ADDR) value_as_address (arg1));
10772 }
6b0d7253 10773
4c4b4cd2
PH
10774 if (ada_is_array_descriptor_type (type))
10775 /* GDB allows dereferencing GNAT array descriptors. */
10776 return ada_coerce_to_simple_array (arg1);
14f9c5c9 10777 else
4c4b4cd2 10778 return ada_value_ind (arg1);
14f9c5c9
AS
10779
10780 case STRUCTOP_STRUCT:
10781 tem = longest_to_int (exp->elts[pc + 1].longconst);
10782 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
10783 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10784 if (noside == EVAL_SKIP)
4c4b4cd2 10785 goto nosideret;
14f9c5c9 10786 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10787 {
df407dfe 10788 struct type *type1 = value_type (arg1);
5b4ee69b 10789
76a01679
JB
10790 if (ada_is_tagged_type (type1, 1))
10791 {
10792 type = ada_lookup_struct_elt_type (type1,
10793 &exp->elts[pc + 2].string,
10794 1, 1, NULL);
10795 if (type == NULL)
10796 /* In this case, we assume that the field COULD exist
10797 in some extension of the type. Return an object of
10798 "type" void, which will match any formal
0963b4bd 10799 (see ada_type_match). */
30b15541
UW
10800 return value_zero (builtin_type (exp->gdbarch)->builtin_void,
10801 lval_memory);
76a01679
JB
10802 }
10803 else
10804 type =
10805 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
10806 0, NULL);
10807
10808 return value_zero (ada_aligned_type (type), lval_memory);
10809 }
14f9c5c9 10810 else
284614f0
JB
10811 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
10812 arg1 = unwrap_value (arg1);
10813 return ada_to_fixed_value (arg1);
10814
14f9c5c9 10815 case OP_TYPE:
4c4b4cd2
PH
10816 /* The value is not supposed to be used. This is here to make it
10817 easier to accommodate expressions that contain types. */
14f9c5c9
AS
10818 (*pos) += 2;
10819 if (noside == EVAL_SKIP)
4c4b4cd2 10820 goto nosideret;
14f9c5c9 10821 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 10822 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 10823 else
323e0a4a 10824 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
10825
10826 case OP_AGGREGATE:
10827 case OP_CHOICES:
10828 case OP_OTHERS:
10829 case OP_DISCRETE_RANGE:
10830 case OP_POSITIONAL:
10831 case OP_NAME:
10832 if (noside == EVAL_NORMAL)
10833 switch (op)
10834 {
10835 case OP_NAME:
10836 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 10837 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
10838 case OP_AGGREGATE:
10839 error (_("Aggregates only allowed on the right of an assignment"));
10840 default:
0963b4bd
MS
10841 internal_error (__FILE__, __LINE__,
10842 _("aggregate apparently mangled"));
52ce6436
PH
10843 }
10844
10845 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10846 *pos += oplen - 1;
10847 for (tem = 0; tem < nargs; tem += 1)
10848 ada_evaluate_subexp (NULL, exp, pos, noside);
10849 goto nosideret;
14f9c5c9
AS
10850 }
10851
10852nosideret:
22601c15 10853 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
14f9c5c9 10854}
14f9c5c9 10855\f
d2e4a39e 10856
4c4b4cd2 10857 /* Fixed point */
14f9c5c9
AS
10858
10859/* If TYPE encodes an Ada fixed-point type, return the suffix of the
10860 type name that encodes the 'small and 'delta information.
4c4b4cd2 10861 Otherwise, return NULL. */
14f9c5c9 10862
d2e4a39e 10863static const char *
ebf56fd3 10864fixed_type_info (struct type *type)
14f9c5c9 10865{
d2e4a39e 10866 const char *name = ada_type_name (type);
14f9c5c9
AS
10867 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
10868
d2e4a39e
AS
10869 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
10870 {
14f9c5c9 10871 const char *tail = strstr (name, "___XF_");
5b4ee69b 10872
14f9c5c9 10873 if (tail == NULL)
4c4b4cd2 10874 return NULL;
d2e4a39e 10875 else
4c4b4cd2 10876 return tail + 5;
14f9c5c9
AS
10877 }
10878 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
10879 return fixed_type_info (TYPE_TARGET_TYPE (type));
10880 else
10881 return NULL;
10882}
10883
4c4b4cd2 10884/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
10885
10886int
ebf56fd3 10887ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
10888{
10889 return fixed_type_info (type) != NULL;
10890}
10891
4c4b4cd2
PH
10892/* Return non-zero iff TYPE represents a System.Address type. */
10893
10894int
10895ada_is_system_address_type (struct type *type)
10896{
10897 return (TYPE_NAME (type)
10898 && strcmp (TYPE_NAME (type), "system__address") == 0);
10899}
10900
14f9c5c9
AS
10901/* Assuming that TYPE is the representation of an Ada fixed-point
10902 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 10903 delta cannot be determined. */
14f9c5c9
AS
10904
10905DOUBLEST
ebf56fd3 10906ada_delta (struct type *type)
14f9c5c9
AS
10907{
10908 const char *encoding = fixed_type_info (type);
facc390f 10909 DOUBLEST num, den;
14f9c5c9 10910
facc390f
JB
10911 /* Strictly speaking, num and den are encoded as integer. However,
10912 they may not fit into a long, and they will have to be converted
10913 to DOUBLEST anyway. So scan them as DOUBLEST. */
10914 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10915 &num, &den) < 2)
14f9c5c9 10916 return -1.0;
d2e4a39e 10917 else
facc390f 10918 return num / den;
14f9c5c9
AS
10919}
10920
10921/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 10922 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
10923
10924static DOUBLEST
ebf56fd3 10925scaling_factor (struct type *type)
14f9c5c9
AS
10926{
10927 const char *encoding = fixed_type_info (type);
facc390f 10928 DOUBLEST num0, den0, num1, den1;
14f9c5c9 10929 int n;
d2e4a39e 10930
facc390f
JB
10931 /* Strictly speaking, num's and den's are encoded as integer. However,
10932 they may not fit into a long, and they will have to be converted
10933 to DOUBLEST anyway. So scan them as DOUBLEST. */
10934 n = sscanf (encoding,
10935 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
10936 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10937 &num0, &den0, &num1, &den1);
14f9c5c9
AS
10938
10939 if (n < 2)
10940 return 1.0;
10941 else if (n == 4)
facc390f 10942 return num1 / den1;
d2e4a39e 10943 else
facc390f 10944 return num0 / den0;
14f9c5c9
AS
10945}
10946
10947
10948/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 10949 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
10950
10951DOUBLEST
ebf56fd3 10952ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 10953{
d2e4a39e 10954 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
10955}
10956
4c4b4cd2
PH
10957/* The representation of a fixed-point value of type TYPE
10958 corresponding to the value X. */
14f9c5c9
AS
10959
10960LONGEST
ebf56fd3 10961ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
10962{
10963 return (LONGEST) (x / scaling_factor (type) + 0.5);
10964}
10965
14f9c5c9 10966\f
d2e4a39e 10967
4c4b4cd2 10968 /* Range types */
14f9c5c9
AS
10969
10970/* Scan STR beginning at position K for a discriminant name, and
10971 return the value of that discriminant field of DVAL in *PX. If
10972 PNEW_K is not null, put the position of the character beyond the
10973 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 10974 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
10975
10976static int
07d8f827 10977scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
76a01679 10978 int *pnew_k)
14f9c5c9
AS
10979{
10980 static char *bound_buffer = NULL;
10981 static size_t bound_buffer_len = 0;
10982 char *bound;
10983 char *pend;
d2e4a39e 10984 struct value *bound_val;
14f9c5c9
AS
10985
10986 if (dval == NULL || str == NULL || str[k] == '\0')
10987 return 0;
10988
d2e4a39e 10989 pend = strstr (str + k, "__");
14f9c5c9
AS
10990 if (pend == NULL)
10991 {
d2e4a39e 10992 bound = str + k;
14f9c5c9
AS
10993 k += strlen (bound);
10994 }
d2e4a39e 10995 else
14f9c5c9 10996 {
d2e4a39e 10997 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
14f9c5c9 10998 bound = bound_buffer;
d2e4a39e
AS
10999 strncpy (bound_buffer, str + k, pend - (str + k));
11000 bound[pend - (str + k)] = '\0';
11001 k = pend - str;
14f9c5c9 11002 }
d2e4a39e 11003
df407dfe 11004 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11005 if (bound_val == NULL)
11006 return 0;
11007
11008 *px = value_as_long (bound_val);
11009 if (pnew_k != NULL)
11010 *pnew_k = k;
11011 return 1;
11012}
11013
11014/* Value of variable named NAME in the current environment. If
11015 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11016 otherwise causes an error with message ERR_MSG. */
11017
d2e4a39e
AS
11018static struct value *
11019get_var_value (char *name, char *err_msg)
14f9c5c9 11020{
4c4b4cd2 11021 struct ada_symbol_info *syms;
14f9c5c9
AS
11022 int nsyms;
11023
4c4b4cd2 11024 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
4eeaa230 11025 &syms);
14f9c5c9
AS
11026
11027 if (nsyms != 1)
11028 {
11029 if (err_msg == NULL)
4c4b4cd2 11030 return 0;
14f9c5c9 11031 else
8a3fe4f8 11032 error (("%s"), err_msg);
14f9c5c9
AS
11033 }
11034
4c4b4cd2 11035 return value_of_variable (syms[0].sym, syms[0].block);
14f9c5c9 11036}
d2e4a39e 11037
14f9c5c9 11038/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
11039 no such variable found, returns 0, and sets *FLAG to 0. If
11040 successful, sets *FLAG to 1. */
11041
14f9c5c9 11042LONGEST
4c4b4cd2 11043get_int_var_value (char *name, int *flag)
14f9c5c9 11044{
4c4b4cd2 11045 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11046
14f9c5c9
AS
11047 if (var_val == 0)
11048 {
11049 if (flag != NULL)
4c4b4cd2 11050 *flag = 0;
14f9c5c9
AS
11051 return 0;
11052 }
11053 else
11054 {
11055 if (flag != NULL)
4c4b4cd2 11056 *flag = 1;
14f9c5c9
AS
11057 return value_as_long (var_val);
11058 }
11059}
d2e4a39e 11060
14f9c5c9
AS
11061
11062/* Return a range type whose base type is that of the range type named
11063 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11064 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11065 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11066 corresponding range type from debug information; fall back to using it
11067 if symbol lookup fails. If a new type must be created, allocate it
11068 like ORIG_TYPE was. The bounds information, in general, is encoded
11069 in NAME, the base type given in the named range type. */
14f9c5c9 11070
d2e4a39e 11071static struct type *
28c85d6c 11072to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11073{
0d5cff50 11074 const char *name;
14f9c5c9 11075 struct type *base_type;
d2e4a39e 11076 char *subtype_info;
14f9c5c9 11077
28c85d6c
JB
11078 gdb_assert (raw_type != NULL);
11079 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11080
1ce677a4 11081 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11082 base_type = TYPE_TARGET_TYPE (raw_type);
11083 else
11084 base_type = raw_type;
11085
28c85d6c 11086 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11087 subtype_info = strstr (name, "___XD");
11088 if (subtype_info == NULL)
690cc4eb 11089 {
43bbcdc2
PH
11090 LONGEST L = ada_discrete_type_low_bound (raw_type);
11091 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11092
690cc4eb
PH
11093 if (L < INT_MIN || U > INT_MAX)
11094 return raw_type;
11095 else
28c85d6c 11096 return create_range_type (alloc_type_copy (raw_type), raw_type,
43bbcdc2
PH
11097 ada_discrete_type_low_bound (raw_type),
11098 ada_discrete_type_high_bound (raw_type));
690cc4eb 11099 }
14f9c5c9
AS
11100 else
11101 {
11102 static char *name_buf = NULL;
11103 static size_t name_len = 0;
11104 int prefix_len = subtype_info - name;
11105 LONGEST L, U;
11106 struct type *type;
11107 char *bounds_str;
11108 int n;
11109
11110 GROW_VECT (name_buf, name_len, prefix_len + 5);
11111 strncpy (name_buf, name, prefix_len);
11112 name_buf[prefix_len] = '\0';
11113
11114 subtype_info += 5;
11115 bounds_str = strchr (subtype_info, '_');
11116 n = 1;
11117
d2e4a39e 11118 if (*subtype_info == 'L')
4c4b4cd2
PH
11119 {
11120 if (!ada_scan_number (bounds_str, n, &L, &n)
11121 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11122 return raw_type;
11123 if (bounds_str[n] == '_')
11124 n += 2;
0963b4bd 11125 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11126 n += 1;
11127 subtype_info += 1;
11128 }
d2e4a39e 11129 else
4c4b4cd2
PH
11130 {
11131 int ok;
5b4ee69b 11132
4c4b4cd2
PH
11133 strcpy (name_buf + prefix_len, "___L");
11134 L = get_int_var_value (name_buf, &ok);
11135 if (!ok)
11136 {
323e0a4a 11137 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11138 L = 1;
11139 }
11140 }
14f9c5c9 11141
d2e4a39e 11142 if (*subtype_info == 'U')
4c4b4cd2
PH
11143 {
11144 if (!ada_scan_number (bounds_str, n, &U, &n)
11145 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11146 return raw_type;
11147 }
d2e4a39e 11148 else
4c4b4cd2
PH
11149 {
11150 int ok;
5b4ee69b 11151
4c4b4cd2
PH
11152 strcpy (name_buf + prefix_len, "___U");
11153 U = get_int_var_value (name_buf, &ok);
11154 if (!ok)
11155 {
323e0a4a 11156 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11157 U = L;
11158 }
11159 }
14f9c5c9 11160
28c85d6c 11161 type = create_range_type (alloc_type_copy (raw_type), base_type, L, U);
d2e4a39e 11162 TYPE_NAME (type) = name;
14f9c5c9
AS
11163 return type;
11164 }
11165}
11166
4c4b4cd2
PH
11167/* True iff NAME is the name of a range type. */
11168
14f9c5c9 11169int
d2e4a39e 11170ada_is_range_type_name (const char *name)
14f9c5c9
AS
11171{
11172 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11173}
14f9c5c9 11174\f
d2e4a39e 11175
4c4b4cd2
PH
11176 /* Modular types */
11177
11178/* True iff TYPE is an Ada modular type. */
14f9c5c9 11179
14f9c5c9 11180int
d2e4a39e 11181ada_is_modular_type (struct type *type)
14f9c5c9 11182{
18af8284 11183 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11184
11185 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11186 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11187 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11188}
11189
4c4b4cd2
PH
11190/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11191
61ee279c 11192ULONGEST
0056e4d5 11193ada_modulus (struct type *type)
14f9c5c9 11194{
43bbcdc2 11195 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11196}
d2e4a39e 11197\f
f7f9143b
JB
11198
11199/* Ada exception catchpoint support:
11200 ---------------------------------
11201
11202 We support 3 kinds of exception catchpoints:
11203 . catchpoints on Ada exceptions
11204 . catchpoints on unhandled Ada exceptions
11205 . catchpoints on failed assertions
11206
11207 Exceptions raised during failed assertions, or unhandled exceptions
11208 could perfectly be caught with the general catchpoint on Ada exceptions.
11209 However, we can easily differentiate these two special cases, and having
11210 the option to distinguish these two cases from the rest can be useful
11211 to zero-in on certain situations.
11212
11213 Exception catchpoints are a specialized form of breakpoint,
11214 since they rely on inserting breakpoints inside known routines
11215 of the GNAT runtime. The implementation therefore uses a standard
11216 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11217 of breakpoint_ops.
11218
0259addd
JB
11219 Support in the runtime for exception catchpoints have been changed
11220 a few times already, and these changes affect the implementation
11221 of these catchpoints. In order to be able to support several
11222 variants of the runtime, we use a sniffer that will determine
28010a5d 11223 the runtime variant used by the program being debugged. */
f7f9143b 11224
3d0b0fa3
JB
11225/* Ada's standard exceptions. */
11226
11227static char *standard_exc[] = {
11228 "constraint_error",
11229 "program_error",
11230 "storage_error",
11231 "tasking_error"
11232};
11233
0259addd
JB
11234typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11235
11236/* A structure that describes how to support exception catchpoints
11237 for a given executable. */
11238
11239struct exception_support_info
11240{
11241 /* The name of the symbol to break on in order to insert
11242 a catchpoint on exceptions. */
11243 const char *catch_exception_sym;
11244
11245 /* The name of the symbol to break on in order to insert
11246 a catchpoint on unhandled exceptions. */
11247 const char *catch_exception_unhandled_sym;
11248
11249 /* The name of the symbol to break on in order to insert
11250 a catchpoint on failed assertions. */
11251 const char *catch_assert_sym;
11252
11253 /* Assuming that the inferior just triggered an unhandled exception
11254 catchpoint, this function is responsible for returning the address
11255 in inferior memory where the name of that exception is stored.
11256 Return zero if the address could not be computed. */
11257 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11258};
11259
11260static CORE_ADDR ada_unhandled_exception_name_addr (void);
11261static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11262
11263/* The following exception support info structure describes how to
11264 implement exception catchpoints with the latest version of the
11265 Ada runtime (as of 2007-03-06). */
11266
11267static const struct exception_support_info default_exception_support_info =
11268{
11269 "__gnat_debug_raise_exception", /* catch_exception_sym */
11270 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11271 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11272 ada_unhandled_exception_name_addr
11273};
11274
11275/* The following exception support info structure describes how to
11276 implement exception catchpoints with a slightly older version
11277 of the Ada runtime. */
11278
11279static const struct exception_support_info exception_support_info_fallback =
11280{
11281 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11282 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11283 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11284 ada_unhandled_exception_name_addr_from_raise
11285};
11286
f17011e0
JB
11287/* Return nonzero if we can detect the exception support routines
11288 described in EINFO.
11289
11290 This function errors out if an abnormal situation is detected
11291 (for instance, if we find the exception support routines, but
11292 that support is found to be incomplete). */
11293
11294static int
11295ada_has_this_exception_support (const struct exception_support_info *einfo)
11296{
11297 struct symbol *sym;
11298
11299 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11300 that should be compiled with debugging information. As a result, we
11301 expect to find that symbol in the symtabs. */
11302
11303 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11304 if (sym == NULL)
a6af7abe
JB
11305 {
11306 /* Perhaps we did not find our symbol because the Ada runtime was
11307 compiled without debugging info, or simply stripped of it.
11308 It happens on some GNU/Linux distributions for instance, where
11309 users have to install a separate debug package in order to get
11310 the runtime's debugging info. In that situation, let the user
11311 know why we cannot insert an Ada exception catchpoint.
11312
11313 Note: Just for the purpose of inserting our Ada exception
11314 catchpoint, we could rely purely on the associated minimal symbol.
11315 But we would be operating in degraded mode anyway, since we are
11316 still lacking the debugging info needed later on to extract
11317 the name of the exception being raised (this name is printed in
11318 the catchpoint message, and is also used when trying to catch
11319 a specific exception). We do not handle this case for now. */
3b7344d5 11320 struct bound_minimal_symbol msym
1c8e84b0
JB
11321 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11322
3b7344d5 11323 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
11324 error (_("Your Ada runtime appears to be missing some debugging "
11325 "information.\nCannot insert Ada exception catchpoint "
11326 "in this configuration."));
11327
11328 return 0;
11329 }
f17011e0
JB
11330
11331 /* Make sure that the symbol we found corresponds to a function. */
11332
11333 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11334 error (_("Symbol \"%s\" is not a function (class = %d)"),
11335 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11336
11337 return 1;
11338}
11339
0259addd
JB
11340/* Inspect the Ada runtime and determine which exception info structure
11341 should be used to provide support for exception catchpoints.
11342
3eecfa55
JB
11343 This function will always set the per-inferior exception_info,
11344 or raise an error. */
0259addd
JB
11345
11346static void
11347ada_exception_support_info_sniffer (void)
11348{
3eecfa55 11349 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
11350
11351 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 11352 if (data->exception_info != NULL)
0259addd
JB
11353 return;
11354
11355 /* Check the latest (default) exception support info. */
f17011e0 11356 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 11357 {
3eecfa55 11358 data->exception_info = &default_exception_support_info;
0259addd
JB
11359 return;
11360 }
11361
11362 /* Try our fallback exception suport info. */
f17011e0 11363 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 11364 {
3eecfa55 11365 data->exception_info = &exception_support_info_fallback;
0259addd
JB
11366 return;
11367 }
11368
11369 /* Sometimes, it is normal for us to not be able to find the routine
11370 we are looking for. This happens when the program is linked with
11371 the shared version of the GNAT runtime, and the program has not been
11372 started yet. Inform the user of these two possible causes if
11373 applicable. */
11374
ccefe4c4 11375 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
11376 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11377
11378 /* If the symbol does not exist, then check that the program is
11379 already started, to make sure that shared libraries have been
11380 loaded. If it is not started, this may mean that the symbol is
11381 in a shared library. */
11382
11383 if (ptid_get_pid (inferior_ptid) == 0)
11384 error (_("Unable to insert catchpoint. Try to start the program first."));
11385
11386 /* At this point, we know that we are debugging an Ada program and
11387 that the inferior has been started, but we still are not able to
0963b4bd 11388 find the run-time symbols. That can mean that we are in
0259addd
JB
11389 configurable run time mode, or that a-except as been optimized
11390 out by the linker... In any case, at this point it is not worth
11391 supporting this feature. */
11392
7dda8cff 11393 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
11394}
11395
f7f9143b
JB
11396/* True iff FRAME is very likely to be that of a function that is
11397 part of the runtime system. This is all very heuristic, but is
11398 intended to be used as advice as to what frames are uninteresting
11399 to most users. */
11400
11401static int
11402is_known_support_routine (struct frame_info *frame)
11403{
4ed6b5be 11404 struct symtab_and_line sal;
55b87a52 11405 char *func_name;
692465f1 11406 enum language func_lang;
f7f9143b 11407 int i;
f35a17b5 11408 const char *fullname;
f7f9143b 11409
4ed6b5be
JB
11410 /* If this code does not have any debugging information (no symtab),
11411 This cannot be any user code. */
f7f9143b 11412
4ed6b5be 11413 find_frame_sal (frame, &sal);
f7f9143b
JB
11414 if (sal.symtab == NULL)
11415 return 1;
11416
4ed6b5be
JB
11417 /* If there is a symtab, but the associated source file cannot be
11418 located, then assume this is not user code: Selecting a frame
11419 for which we cannot display the code would not be very helpful
11420 for the user. This should also take care of case such as VxWorks
11421 where the kernel has some debugging info provided for a few units. */
f7f9143b 11422
f35a17b5
JK
11423 fullname = symtab_to_fullname (sal.symtab);
11424 if (access (fullname, R_OK) != 0)
f7f9143b
JB
11425 return 1;
11426
4ed6b5be
JB
11427 /* Check the unit filename againt the Ada runtime file naming.
11428 We also check the name of the objfile against the name of some
11429 known system libraries that sometimes come with debugging info
11430 too. */
11431
f7f9143b
JB
11432 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11433 {
11434 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 11435 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 11436 return 1;
4ed6b5be 11437 if (sal.symtab->objfile != NULL
4262abfb 11438 && re_exec (objfile_name (sal.symtab->objfile)))
4ed6b5be 11439 return 1;
f7f9143b
JB
11440 }
11441
4ed6b5be 11442 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 11443
e9e07ba6 11444 find_frame_funname (frame, &func_name, &func_lang, NULL);
f7f9143b
JB
11445 if (func_name == NULL)
11446 return 1;
11447
11448 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11449 {
11450 re_comp (known_auxiliary_function_name_patterns[i]);
11451 if (re_exec (func_name))
55b87a52
KS
11452 {
11453 xfree (func_name);
11454 return 1;
11455 }
f7f9143b
JB
11456 }
11457
55b87a52 11458 xfree (func_name);
f7f9143b
JB
11459 return 0;
11460}
11461
11462/* Find the first frame that contains debugging information and that is not
11463 part of the Ada run-time, starting from FI and moving upward. */
11464
0ef643c8 11465void
f7f9143b
JB
11466ada_find_printable_frame (struct frame_info *fi)
11467{
11468 for (; fi != NULL; fi = get_prev_frame (fi))
11469 {
11470 if (!is_known_support_routine (fi))
11471 {
11472 select_frame (fi);
11473 break;
11474 }
11475 }
11476
11477}
11478
11479/* Assuming that the inferior just triggered an unhandled exception
11480 catchpoint, return the address in inferior memory where the name
11481 of the exception is stored.
11482
11483 Return zero if the address could not be computed. */
11484
11485static CORE_ADDR
11486ada_unhandled_exception_name_addr (void)
0259addd
JB
11487{
11488 return parse_and_eval_address ("e.full_name");
11489}
11490
11491/* Same as ada_unhandled_exception_name_addr, except that this function
11492 should be used when the inferior uses an older version of the runtime,
11493 where the exception name needs to be extracted from a specific frame
11494 several frames up in the callstack. */
11495
11496static CORE_ADDR
11497ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
11498{
11499 int frame_level;
11500 struct frame_info *fi;
3eecfa55 11501 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
55b87a52 11502 struct cleanup *old_chain;
f7f9143b
JB
11503
11504 /* To determine the name of this exception, we need to select
11505 the frame corresponding to RAISE_SYM_NAME. This frame is
11506 at least 3 levels up, so we simply skip the first 3 frames
11507 without checking the name of their associated function. */
11508 fi = get_current_frame ();
11509 for (frame_level = 0; frame_level < 3; frame_level += 1)
11510 if (fi != NULL)
11511 fi = get_prev_frame (fi);
11512
55b87a52 11513 old_chain = make_cleanup (null_cleanup, NULL);
f7f9143b
JB
11514 while (fi != NULL)
11515 {
55b87a52 11516 char *func_name;
692465f1
JB
11517 enum language func_lang;
11518
e9e07ba6 11519 find_frame_funname (fi, &func_name, &func_lang, NULL);
55b87a52
KS
11520 if (func_name != NULL)
11521 {
11522 make_cleanup (xfree, func_name);
11523
11524 if (strcmp (func_name,
11525 data->exception_info->catch_exception_sym) == 0)
11526 break; /* We found the frame we were looking for... */
11527 fi = get_prev_frame (fi);
11528 }
f7f9143b 11529 }
55b87a52 11530 do_cleanups (old_chain);
f7f9143b
JB
11531
11532 if (fi == NULL)
11533 return 0;
11534
11535 select_frame (fi);
11536 return parse_and_eval_address ("id.full_name");
11537}
11538
11539/* Assuming the inferior just triggered an Ada exception catchpoint
11540 (of any type), return the address in inferior memory where the name
11541 of the exception is stored, if applicable.
11542
11543 Return zero if the address could not be computed, or if not relevant. */
11544
11545static CORE_ADDR
761269c8 11546ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11547 struct breakpoint *b)
11548{
3eecfa55
JB
11549 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11550
f7f9143b
JB
11551 switch (ex)
11552 {
761269c8 11553 case ada_catch_exception:
f7f9143b
JB
11554 return (parse_and_eval_address ("e.full_name"));
11555 break;
11556
761269c8 11557 case ada_catch_exception_unhandled:
3eecfa55 11558 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
11559 break;
11560
761269c8 11561 case ada_catch_assert:
f7f9143b
JB
11562 return 0; /* Exception name is not relevant in this case. */
11563 break;
11564
11565 default:
11566 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11567 break;
11568 }
11569
11570 return 0; /* Should never be reached. */
11571}
11572
11573/* Same as ada_exception_name_addr_1, except that it intercepts and contains
11574 any error that ada_exception_name_addr_1 might cause to be thrown.
11575 When an error is intercepted, a warning with the error message is printed,
11576 and zero is returned. */
11577
11578static CORE_ADDR
761269c8 11579ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11580 struct breakpoint *b)
11581{
bfd189b1 11582 volatile struct gdb_exception e;
f7f9143b
JB
11583 CORE_ADDR result = 0;
11584
11585 TRY_CATCH (e, RETURN_MASK_ERROR)
11586 {
11587 result = ada_exception_name_addr_1 (ex, b);
11588 }
11589
11590 if (e.reason < 0)
11591 {
11592 warning (_("failed to get exception name: %s"), e.message);
11593 return 0;
11594 }
11595
11596 return result;
11597}
11598
28010a5d
PA
11599static char *ada_exception_catchpoint_cond_string (const char *excep_string);
11600
11601/* Ada catchpoints.
11602
11603 In the case of catchpoints on Ada exceptions, the catchpoint will
11604 stop the target on every exception the program throws. When a user
11605 specifies the name of a specific exception, we translate this
11606 request into a condition expression (in text form), and then parse
11607 it into an expression stored in each of the catchpoint's locations.
11608 We then use this condition to check whether the exception that was
11609 raised is the one the user is interested in. If not, then the
11610 target is resumed again. We store the name of the requested
11611 exception, in order to be able to re-set the condition expression
11612 when symbols change. */
11613
11614/* An instance of this type is used to represent an Ada catchpoint
11615 breakpoint location. It includes a "struct bp_location" as a kind
11616 of base class; users downcast to "struct bp_location *" when
11617 needed. */
11618
11619struct ada_catchpoint_location
11620{
11621 /* The base class. */
11622 struct bp_location base;
11623
11624 /* The condition that checks whether the exception that was raised
11625 is the specific exception the user specified on catchpoint
11626 creation. */
11627 struct expression *excep_cond_expr;
11628};
11629
11630/* Implement the DTOR method in the bp_location_ops structure for all
11631 Ada exception catchpoint kinds. */
11632
11633static void
11634ada_catchpoint_location_dtor (struct bp_location *bl)
11635{
11636 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
11637
11638 xfree (al->excep_cond_expr);
11639}
11640
11641/* The vtable to be used in Ada catchpoint locations. */
11642
11643static const struct bp_location_ops ada_catchpoint_location_ops =
11644{
11645 ada_catchpoint_location_dtor
11646};
11647
11648/* An instance of this type is used to represent an Ada catchpoint.
11649 It includes a "struct breakpoint" as a kind of base class; users
11650 downcast to "struct breakpoint *" when needed. */
11651
11652struct ada_catchpoint
11653{
11654 /* The base class. */
11655 struct breakpoint base;
11656
11657 /* The name of the specific exception the user specified. */
11658 char *excep_string;
11659};
11660
11661/* Parse the exception condition string in the context of each of the
11662 catchpoint's locations, and store them for later evaluation. */
11663
11664static void
11665create_excep_cond_exprs (struct ada_catchpoint *c)
11666{
11667 struct cleanup *old_chain;
11668 struct bp_location *bl;
11669 char *cond_string;
11670
11671 /* Nothing to do if there's no specific exception to catch. */
11672 if (c->excep_string == NULL)
11673 return;
11674
11675 /* Same if there are no locations... */
11676 if (c->base.loc == NULL)
11677 return;
11678
11679 /* Compute the condition expression in text form, from the specific
11680 expection we want to catch. */
11681 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
11682 old_chain = make_cleanup (xfree, cond_string);
11683
11684 /* Iterate over all the catchpoint's locations, and parse an
11685 expression for each. */
11686 for (bl = c->base.loc; bl != NULL; bl = bl->next)
11687 {
11688 struct ada_catchpoint_location *ada_loc
11689 = (struct ada_catchpoint_location *) bl;
11690 struct expression *exp = NULL;
11691
11692 if (!bl->shlib_disabled)
11693 {
11694 volatile struct gdb_exception e;
bbc13ae3 11695 const char *s;
28010a5d
PA
11696
11697 s = cond_string;
11698 TRY_CATCH (e, RETURN_MASK_ERROR)
11699 {
1bb9788d
TT
11700 exp = parse_exp_1 (&s, bl->address,
11701 block_for_pc (bl->address), 0);
28010a5d
PA
11702 }
11703 if (e.reason < 0)
849f2b52
JB
11704 {
11705 warning (_("failed to reevaluate internal exception condition "
11706 "for catchpoint %d: %s"),
11707 c->base.number, e.message);
11708 /* There is a bug in GCC on sparc-solaris when building with
11709 optimization which causes EXP to change unexpectedly
11710 (http://gcc.gnu.org/bugzilla/show_bug.cgi?id=56982).
11711 The problem should be fixed starting with GCC 4.9.
11712 In the meantime, work around it by forcing EXP back
11713 to NULL. */
11714 exp = NULL;
11715 }
28010a5d
PA
11716 }
11717
11718 ada_loc->excep_cond_expr = exp;
11719 }
11720
11721 do_cleanups (old_chain);
11722}
11723
11724/* Implement the DTOR method in the breakpoint_ops structure for all
11725 exception catchpoint kinds. */
11726
11727static void
761269c8 11728dtor_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
11729{
11730 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11731
11732 xfree (c->excep_string);
348d480f 11733
2060206e 11734 bkpt_breakpoint_ops.dtor (b);
28010a5d
PA
11735}
11736
11737/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11738 structure for all exception catchpoint kinds. */
11739
11740static struct bp_location *
761269c8 11741allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
11742 struct breakpoint *self)
11743{
11744 struct ada_catchpoint_location *loc;
11745
11746 loc = XNEW (struct ada_catchpoint_location);
11747 init_bp_location (&loc->base, &ada_catchpoint_location_ops, self);
11748 loc->excep_cond_expr = NULL;
11749 return &loc->base;
11750}
11751
11752/* Implement the RE_SET method in the breakpoint_ops structure for all
11753 exception catchpoint kinds. */
11754
11755static void
761269c8 11756re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
11757{
11758 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11759
11760 /* Call the base class's method. This updates the catchpoint's
11761 locations. */
2060206e 11762 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
11763
11764 /* Reparse the exception conditional expressions. One for each
11765 location. */
11766 create_excep_cond_exprs (c);
11767}
11768
11769/* Returns true if we should stop for this breakpoint hit. If the
11770 user specified a specific exception, we only want to cause a stop
11771 if the program thrown that exception. */
11772
11773static int
11774should_stop_exception (const struct bp_location *bl)
11775{
11776 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11777 const struct ada_catchpoint_location *ada_loc
11778 = (const struct ada_catchpoint_location *) bl;
11779 volatile struct gdb_exception ex;
11780 int stop;
11781
11782 /* With no specific exception, should always stop. */
11783 if (c->excep_string == NULL)
11784 return 1;
11785
11786 if (ada_loc->excep_cond_expr == NULL)
11787 {
11788 /* We will have a NULL expression if back when we were creating
11789 the expressions, this location's had failed to parse. */
11790 return 1;
11791 }
11792
11793 stop = 1;
11794 TRY_CATCH (ex, RETURN_MASK_ALL)
11795 {
11796 struct value *mark;
11797
11798 mark = value_mark ();
11799 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr));
11800 value_free_to_mark (mark);
11801 }
11802 if (ex.reason < 0)
11803 exception_fprintf (gdb_stderr, ex,
11804 _("Error in testing exception condition:\n"));
11805 return stop;
11806}
11807
11808/* Implement the CHECK_STATUS method in the breakpoint_ops structure
11809 for all exception catchpoint kinds. */
11810
11811static void
761269c8 11812check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
11813{
11814 bs->stop = should_stop_exception (bs->bp_location_at);
11815}
11816
f7f9143b
JB
11817/* Implement the PRINT_IT method in the breakpoint_ops structure
11818 for all exception catchpoint kinds. */
11819
11820static enum print_stop_action
761269c8 11821print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 11822{
79a45e25 11823 struct ui_out *uiout = current_uiout;
348d480f
PA
11824 struct breakpoint *b = bs->breakpoint_at;
11825
956a9fb9 11826 annotate_catchpoint (b->number);
f7f9143b 11827
956a9fb9 11828 if (ui_out_is_mi_like_p (uiout))
f7f9143b 11829 {
956a9fb9
JB
11830 ui_out_field_string (uiout, "reason",
11831 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11832 ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition));
f7f9143b
JB
11833 }
11834
00eb2c4a
JB
11835 ui_out_text (uiout,
11836 b->disposition == disp_del ? "\nTemporary catchpoint "
11837 : "\nCatchpoint ");
956a9fb9
JB
11838 ui_out_field_int (uiout, "bkptno", b->number);
11839 ui_out_text (uiout, ", ");
f7f9143b 11840
f7f9143b
JB
11841 switch (ex)
11842 {
761269c8
JB
11843 case ada_catch_exception:
11844 case ada_catch_exception_unhandled:
956a9fb9
JB
11845 {
11846 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
11847 char exception_name[256];
11848
11849 if (addr != 0)
11850 {
c714b426
PA
11851 read_memory (addr, (gdb_byte *) exception_name,
11852 sizeof (exception_name) - 1);
956a9fb9
JB
11853 exception_name [sizeof (exception_name) - 1] = '\0';
11854 }
11855 else
11856 {
11857 /* For some reason, we were unable to read the exception
11858 name. This could happen if the Runtime was compiled
11859 without debugging info, for instance. In that case,
11860 just replace the exception name by the generic string
11861 "exception" - it will read as "an exception" in the
11862 notification we are about to print. */
967cff16 11863 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
11864 }
11865 /* In the case of unhandled exception breakpoints, we print
11866 the exception name as "unhandled EXCEPTION_NAME", to make
11867 it clearer to the user which kind of catchpoint just got
11868 hit. We used ui_out_text to make sure that this extra
11869 info does not pollute the exception name in the MI case. */
761269c8 11870 if (ex == ada_catch_exception_unhandled)
956a9fb9
JB
11871 ui_out_text (uiout, "unhandled ");
11872 ui_out_field_string (uiout, "exception-name", exception_name);
11873 }
11874 break;
761269c8 11875 case ada_catch_assert:
956a9fb9
JB
11876 /* In this case, the name of the exception is not really
11877 important. Just print "failed assertion" to make it clearer
11878 that his program just hit an assertion-failure catchpoint.
11879 We used ui_out_text because this info does not belong in
11880 the MI output. */
11881 ui_out_text (uiout, "failed assertion");
11882 break;
f7f9143b 11883 }
956a9fb9
JB
11884 ui_out_text (uiout, " at ");
11885 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
11886
11887 return PRINT_SRC_AND_LOC;
11888}
11889
11890/* Implement the PRINT_ONE method in the breakpoint_ops structure
11891 for all exception catchpoint kinds. */
11892
11893static void
761269c8 11894print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 11895 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11896{
79a45e25 11897 struct ui_out *uiout = current_uiout;
28010a5d 11898 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
11899 struct value_print_options opts;
11900
11901 get_user_print_options (&opts);
11902 if (opts.addressprint)
f7f9143b
JB
11903 {
11904 annotate_field (4);
5af949e3 11905 ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
11906 }
11907
11908 annotate_field (5);
a6d9a66e 11909 *last_loc = b->loc;
f7f9143b
JB
11910 switch (ex)
11911 {
761269c8 11912 case ada_catch_exception:
28010a5d 11913 if (c->excep_string != NULL)
f7f9143b 11914 {
28010a5d
PA
11915 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11916
f7f9143b
JB
11917 ui_out_field_string (uiout, "what", msg);
11918 xfree (msg);
11919 }
11920 else
11921 ui_out_field_string (uiout, "what", "all Ada exceptions");
11922
11923 break;
11924
761269c8 11925 case ada_catch_exception_unhandled:
f7f9143b
JB
11926 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
11927 break;
11928
761269c8 11929 case ada_catch_assert:
f7f9143b
JB
11930 ui_out_field_string (uiout, "what", "failed Ada assertions");
11931 break;
11932
11933 default:
11934 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11935 break;
11936 }
11937}
11938
11939/* Implement the PRINT_MENTION method in the breakpoint_ops structure
11940 for all exception catchpoint kinds. */
11941
11942static void
761269c8 11943print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11944 struct breakpoint *b)
11945{
28010a5d 11946 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 11947 struct ui_out *uiout = current_uiout;
28010a5d 11948
00eb2c4a
JB
11949 ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ")
11950 : _("Catchpoint "));
11951 ui_out_field_int (uiout, "bkptno", b->number);
11952 ui_out_text (uiout, ": ");
11953
f7f9143b
JB
11954 switch (ex)
11955 {
761269c8 11956 case ada_catch_exception:
28010a5d 11957 if (c->excep_string != NULL)
00eb2c4a
JB
11958 {
11959 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11960 struct cleanup *old_chain = make_cleanup (xfree, info);
11961
11962 ui_out_text (uiout, info);
11963 do_cleanups (old_chain);
11964 }
f7f9143b 11965 else
00eb2c4a 11966 ui_out_text (uiout, _("all Ada exceptions"));
f7f9143b
JB
11967 break;
11968
761269c8 11969 case ada_catch_exception_unhandled:
00eb2c4a 11970 ui_out_text (uiout, _("unhandled Ada exceptions"));
f7f9143b
JB
11971 break;
11972
761269c8 11973 case ada_catch_assert:
00eb2c4a 11974 ui_out_text (uiout, _("failed Ada assertions"));
f7f9143b
JB
11975 break;
11976
11977 default:
11978 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11979 break;
11980 }
11981}
11982
6149aea9
PA
11983/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
11984 for all exception catchpoint kinds. */
11985
11986static void
761269c8 11987print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
11988 struct breakpoint *b, struct ui_file *fp)
11989{
28010a5d
PA
11990 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11991
6149aea9
PA
11992 switch (ex)
11993 {
761269c8 11994 case ada_catch_exception:
6149aea9 11995 fprintf_filtered (fp, "catch exception");
28010a5d
PA
11996 if (c->excep_string != NULL)
11997 fprintf_filtered (fp, " %s", c->excep_string);
6149aea9
PA
11998 break;
11999
761269c8 12000 case ada_catch_exception_unhandled:
78076abc 12001 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12002 break;
12003
761269c8 12004 case ada_catch_assert:
6149aea9
PA
12005 fprintf_filtered (fp, "catch assert");
12006 break;
12007
12008 default:
12009 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12010 }
d9b3f62e 12011 print_recreate_thread (b, fp);
6149aea9
PA
12012}
12013
f7f9143b
JB
12014/* Virtual table for "catch exception" breakpoints. */
12015
28010a5d
PA
12016static void
12017dtor_catch_exception (struct breakpoint *b)
12018{
761269c8 12019 dtor_exception (ada_catch_exception, b);
28010a5d
PA
12020}
12021
12022static struct bp_location *
12023allocate_location_catch_exception (struct breakpoint *self)
12024{
761269c8 12025 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12026}
12027
12028static void
12029re_set_catch_exception (struct breakpoint *b)
12030{
761269c8 12031 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12032}
12033
12034static void
12035check_status_catch_exception (bpstat bs)
12036{
761269c8 12037 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12038}
12039
f7f9143b 12040static enum print_stop_action
348d480f 12041print_it_catch_exception (bpstat bs)
f7f9143b 12042{
761269c8 12043 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12044}
12045
12046static void
a6d9a66e 12047print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12048{
761269c8 12049 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12050}
12051
12052static void
12053print_mention_catch_exception (struct breakpoint *b)
12054{
761269c8 12055 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12056}
12057
6149aea9
PA
12058static void
12059print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12060{
761269c8 12061 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12062}
12063
2060206e 12064static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12065
12066/* Virtual table for "catch exception unhandled" breakpoints. */
12067
28010a5d
PA
12068static void
12069dtor_catch_exception_unhandled (struct breakpoint *b)
12070{
761269c8 12071 dtor_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12072}
12073
12074static struct bp_location *
12075allocate_location_catch_exception_unhandled (struct breakpoint *self)
12076{
761269c8 12077 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12078}
12079
12080static void
12081re_set_catch_exception_unhandled (struct breakpoint *b)
12082{
761269c8 12083 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12084}
12085
12086static void
12087check_status_catch_exception_unhandled (bpstat bs)
12088{
761269c8 12089 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12090}
12091
f7f9143b 12092static enum print_stop_action
348d480f 12093print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12094{
761269c8 12095 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12096}
12097
12098static void
a6d9a66e
UW
12099print_one_catch_exception_unhandled (struct breakpoint *b,
12100 struct bp_location **last_loc)
f7f9143b 12101{
761269c8 12102 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12103}
12104
12105static void
12106print_mention_catch_exception_unhandled (struct breakpoint *b)
12107{
761269c8 12108 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12109}
12110
6149aea9
PA
12111static void
12112print_recreate_catch_exception_unhandled (struct breakpoint *b,
12113 struct ui_file *fp)
12114{
761269c8 12115 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12116}
12117
2060206e 12118static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12119
12120/* Virtual table for "catch assert" breakpoints. */
12121
28010a5d
PA
12122static void
12123dtor_catch_assert (struct breakpoint *b)
12124{
761269c8 12125 dtor_exception (ada_catch_assert, b);
28010a5d
PA
12126}
12127
12128static struct bp_location *
12129allocate_location_catch_assert (struct breakpoint *self)
12130{
761269c8 12131 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12132}
12133
12134static void
12135re_set_catch_assert (struct breakpoint *b)
12136{
761269c8 12137 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12138}
12139
12140static void
12141check_status_catch_assert (bpstat bs)
12142{
761269c8 12143 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12144}
12145
f7f9143b 12146static enum print_stop_action
348d480f 12147print_it_catch_assert (bpstat bs)
f7f9143b 12148{
761269c8 12149 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12150}
12151
12152static void
a6d9a66e 12153print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12154{
761269c8 12155 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
12156}
12157
12158static void
12159print_mention_catch_assert (struct breakpoint *b)
12160{
761269c8 12161 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
12162}
12163
6149aea9
PA
12164static void
12165print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12166{
761269c8 12167 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
12168}
12169
2060206e 12170static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 12171
f7f9143b
JB
12172/* Return a newly allocated copy of the first space-separated token
12173 in ARGSP, and then adjust ARGSP to point immediately after that
12174 token.
12175
12176 Return NULL if ARGPS does not contain any more tokens. */
12177
12178static char *
12179ada_get_next_arg (char **argsp)
12180{
12181 char *args = *argsp;
12182 char *end;
12183 char *result;
12184
0fcd72ba 12185 args = skip_spaces (args);
f7f9143b
JB
12186 if (args[0] == '\0')
12187 return NULL; /* No more arguments. */
12188
12189 /* Find the end of the current argument. */
12190
0fcd72ba 12191 end = skip_to_space (args);
f7f9143b
JB
12192
12193 /* Adjust ARGSP to point to the start of the next argument. */
12194
12195 *argsp = end;
12196
12197 /* Make a copy of the current argument and return it. */
12198
12199 result = xmalloc (end - args + 1);
12200 strncpy (result, args, end - args);
12201 result[end - args] = '\0';
12202
12203 return result;
12204}
12205
12206/* Split the arguments specified in a "catch exception" command.
12207 Set EX to the appropriate catchpoint type.
28010a5d 12208 Set EXCEP_STRING to the name of the specific exception if
5845583d
JB
12209 specified by the user.
12210 If a condition is found at the end of the arguments, the condition
12211 expression is stored in COND_STRING (memory must be deallocated
12212 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
12213
12214static void
12215catch_ada_exception_command_split (char *args,
761269c8 12216 enum ada_exception_catchpoint_kind *ex,
5845583d
JB
12217 char **excep_string,
12218 char **cond_string)
f7f9143b
JB
12219{
12220 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
12221 char *exception_name;
5845583d 12222 char *cond = NULL;
f7f9143b
JB
12223
12224 exception_name = ada_get_next_arg (&args);
5845583d
JB
12225 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
12226 {
12227 /* This is not an exception name; this is the start of a condition
12228 expression for a catchpoint on all exceptions. So, "un-get"
12229 this token, and set exception_name to NULL. */
12230 xfree (exception_name);
12231 exception_name = NULL;
12232 args -= 2;
12233 }
f7f9143b
JB
12234 make_cleanup (xfree, exception_name);
12235
5845583d 12236 /* Check to see if we have a condition. */
f7f9143b 12237
0fcd72ba 12238 args = skip_spaces (args);
5845583d
JB
12239 if (strncmp (args, "if", 2) == 0
12240 && (isspace (args[2]) || args[2] == '\0'))
12241 {
12242 args += 2;
12243 args = skip_spaces (args);
12244
12245 if (args[0] == '\0')
12246 error (_("Condition missing after `if' keyword"));
12247 cond = xstrdup (args);
12248 make_cleanup (xfree, cond);
12249
12250 args += strlen (args);
12251 }
12252
12253 /* Check that we do not have any more arguments. Anything else
12254 is unexpected. */
f7f9143b
JB
12255
12256 if (args[0] != '\0')
12257 error (_("Junk at end of expression"));
12258
12259 discard_cleanups (old_chain);
12260
12261 if (exception_name == NULL)
12262 {
12263 /* Catch all exceptions. */
761269c8 12264 *ex = ada_catch_exception;
28010a5d 12265 *excep_string = NULL;
f7f9143b
JB
12266 }
12267 else if (strcmp (exception_name, "unhandled") == 0)
12268 {
12269 /* Catch unhandled exceptions. */
761269c8 12270 *ex = ada_catch_exception_unhandled;
28010a5d 12271 *excep_string = NULL;
f7f9143b
JB
12272 }
12273 else
12274 {
12275 /* Catch a specific exception. */
761269c8 12276 *ex = ada_catch_exception;
28010a5d 12277 *excep_string = exception_name;
f7f9143b 12278 }
5845583d 12279 *cond_string = cond;
f7f9143b
JB
12280}
12281
12282/* Return the name of the symbol on which we should break in order to
12283 implement a catchpoint of the EX kind. */
12284
12285static const char *
761269c8 12286ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 12287{
3eecfa55
JB
12288 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12289
12290 gdb_assert (data->exception_info != NULL);
0259addd 12291
f7f9143b
JB
12292 switch (ex)
12293 {
761269c8 12294 case ada_catch_exception:
3eecfa55 12295 return (data->exception_info->catch_exception_sym);
f7f9143b 12296 break;
761269c8 12297 case ada_catch_exception_unhandled:
3eecfa55 12298 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 12299 break;
761269c8 12300 case ada_catch_assert:
3eecfa55 12301 return (data->exception_info->catch_assert_sym);
f7f9143b
JB
12302 break;
12303 default:
12304 internal_error (__FILE__, __LINE__,
12305 _("unexpected catchpoint kind (%d)"), ex);
12306 }
12307}
12308
12309/* Return the breakpoint ops "virtual table" used for catchpoints
12310 of the EX kind. */
12311
c0a91b2b 12312static const struct breakpoint_ops *
761269c8 12313ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
12314{
12315 switch (ex)
12316 {
761269c8 12317 case ada_catch_exception:
f7f9143b
JB
12318 return (&catch_exception_breakpoint_ops);
12319 break;
761269c8 12320 case ada_catch_exception_unhandled:
f7f9143b
JB
12321 return (&catch_exception_unhandled_breakpoint_ops);
12322 break;
761269c8 12323 case ada_catch_assert:
f7f9143b
JB
12324 return (&catch_assert_breakpoint_ops);
12325 break;
12326 default:
12327 internal_error (__FILE__, __LINE__,
12328 _("unexpected catchpoint kind (%d)"), ex);
12329 }
12330}
12331
12332/* Return the condition that will be used to match the current exception
12333 being raised with the exception that the user wants to catch. This
12334 assumes that this condition is used when the inferior just triggered
12335 an exception catchpoint.
12336
12337 The string returned is a newly allocated string that needs to be
12338 deallocated later. */
12339
12340static char *
28010a5d 12341ada_exception_catchpoint_cond_string (const char *excep_string)
f7f9143b 12342{
3d0b0fa3
JB
12343 int i;
12344
0963b4bd 12345 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 12346 runtime units that have been compiled without debugging info; if
28010a5d 12347 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
12348 exception (e.g. "constraint_error") then, during the evaluation
12349 of the condition expression, the symbol lookup on this name would
0963b4bd 12350 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
12351 may then be set only on user-defined exceptions which have the
12352 same not-fully-qualified name (e.g. my_package.constraint_error).
12353
12354 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 12355 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
12356 exception constraint_error" is rewritten into "catch exception
12357 standard.constraint_error".
12358
12359 If an exception named contraint_error is defined in another package of
12360 the inferior program, then the only way to specify this exception as a
12361 breakpoint condition is to use its fully-qualified named:
12362 e.g. my_package.constraint_error. */
12363
12364 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12365 {
28010a5d 12366 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3
JB
12367 {
12368 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
28010a5d 12369 excep_string);
3d0b0fa3
JB
12370 }
12371 }
28010a5d 12372 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
f7f9143b
JB
12373}
12374
12375/* Return the symtab_and_line that should be used to insert an exception
12376 catchpoint of the TYPE kind.
12377
28010a5d
PA
12378 EXCEP_STRING should contain the name of a specific exception that
12379 the catchpoint should catch, or NULL otherwise.
f7f9143b 12380
28010a5d
PA
12381 ADDR_STRING returns the name of the function where the real
12382 breakpoint that implements the catchpoints is set, depending on the
12383 type of catchpoint we need to create. */
f7f9143b
JB
12384
12385static struct symtab_and_line
761269c8 12386ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
c0a91b2b 12387 char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
12388{
12389 const char *sym_name;
12390 struct symbol *sym;
f7f9143b 12391
0259addd
JB
12392 /* First, find out which exception support info to use. */
12393 ada_exception_support_info_sniffer ();
12394
12395 /* Then lookup the function on which we will break in order to catch
f7f9143b 12396 the Ada exceptions requested by the user. */
f7f9143b
JB
12397 sym_name = ada_exception_sym_name (ex);
12398 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12399
f17011e0
JB
12400 /* We can assume that SYM is not NULL at this stage. If the symbol
12401 did not exist, ada_exception_support_info_sniffer would have
12402 raised an exception.
f7f9143b 12403
f17011e0
JB
12404 Also, ada_exception_support_info_sniffer should have already
12405 verified that SYM is a function symbol. */
12406 gdb_assert (sym != NULL);
12407 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
12408
12409 /* Set ADDR_STRING. */
f7f9143b
JB
12410 *addr_string = xstrdup (sym_name);
12411
f7f9143b 12412 /* Set OPS. */
4b9eee8c 12413 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 12414
f17011e0 12415 return find_function_start_sal (sym, 1);
f7f9143b
JB
12416}
12417
b4a5b78b 12418/* Create an Ada exception catchpoint.
f7f9143b 12419
b4a5b78b 12420 EX_KIND is the kind of exception catchpoint to be created.
5845583d 12421
2df4d1d5
JB
12422 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
12423 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12424 of the exception to which this catchpoint applies. When not NULL,
12425 the string must be allocated on the heap, and its deallocation
12426 is no longer the responsibility of the caller.
12427
12428 COND_STRING, if not NULL, is the catchpoint condition. This string
12429 must be allocated on the heap, and its deallocation is no longer
12430 the responsibility of the caller.
f7f9143b 12431
b4a5b78b
JB
12432 TEMPFLAG, if nonzero, means that the underlying breakpoint
12433 should be temporary.
28010a5d 12434
b4a5b78b 12435 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 12436
349774ef 12437void
28010a5d 12438create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 12439 enum ada_exception_catchpoint_kind ex_kind,
28010a5d 12440 char *excep_string,
5845583d 12441 char *cond_string,
28010a5d 12442 int tempflag,
349774ef 12443 int disabled,
28010a5d
PA
12444 int from_tty)
12445{
12446 struct ada_catchpoint *c;
b4a5b78b
JB
12447 char *addr_string = NULL;
12448 const struct breakpoint_ops *ops = NULL;
12449 struct symtab_and_line sal
12450 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
28010a5d
PA
12451
12452 c = XNEW (struct ada_catchpoint);
12453 init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string,
349774ef 12454 ops, tempflag, disabled, from_tty);
28010a5d
PA
12455 c->excep_string = excep_string;
12456 create_excep_cond_exprs (c);
5845583d
JB
12457 if (cond_string != NULL)
12458 set_breakpoint_condition (&c->base, cond_string, from_tty);
3ea46bff 12459 install_breakpoint (0, &c->base, 1);
f7f9143b
JB
12460}
12461
9ac4176b
PA
12462/* Implement the "catch exception" command. */
12463
12464static void
12465catch_ada_exception_command (char *arg, int from_tty,
12466 struct cmd_list_element *command)
12467{
12468 struct gdbarch *gdbarch = get_current_arch ();
12469 int tempflag;
761269c8 12470 enum ada_exception_catchpoint_kind ex_kind;
28010a5d 12471 char *excep_string = NULL;
5845583d 12472 char *cond_string = NULL;
9ac4176b
PA
12473
12474 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12475
12476 if (!arg)
12477 arg = "";
b4a5b78b
JB
12478 catch_ada_exception_command_split (arg, &ex_kind, &excep_string,
12479 &cond_string);
12480 create_ada_exception_catchpoint (gdbarch, ex_kind,
12481 excep_string, cond_string,
349774ef
JB
12482 tempflag, 1 /* enabled */,
12483 from_tty);
9ac4176b
PA
12484}
12485
b4a5b78b 12486/* Split the arguments specified in a "catch assert" command.
5845583d 12487
b4a5b78b
JB
12488 ARGS contains the command's arguments (or the empty string if
12489 no arguments were passed).
5845583d
JB
12490
12491 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 12492 (the memory needs to be deallocated after use). */
5845583d 12493
b4a5b78b
JB
12494static void
12495catch_ada_assert_command_split (char *args, char **cond_string)
f7f9143b 12496{
5845583d 12497 args = skip_spaces (args);
f7f9143b 12498
5845583d
JB
12499 /* Check whether a condition was provided. */
12500 if (strncmp (args, "if", 2) == 0
12501 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 12502 {
5845583d 12503 args += 2;
0fcd72ba 12504 args = skip_spaces (args);
5845583d
JB
12505 if (args[0] == '\0')
12506 error (_("condition missing after `if' keyword"));
12507 *cond_string = xstrdup (args);
f7f9143b
JB
12508 }
12509
5845583d
JB
12510 /* Otherwise, there should be no other argument at the end of
12511 the command. */
12512 else if (args[0] != '\0')
12513 error (_("Junk at end of arguments."));
f7f9143b
JB
12514}
12515
9ac4176b
PA
12516/* Implement the "catch assert" command. */
12517
12518static void
12519catch_assert_command (char *arg, int from_tty,
12520 struct cmd_list_element *command)
12521{
12522 struct gdbarch *gdbarch = get_current_arch ();
12523 int tempflag;
5845583d 12524 char *cond_string = NULL;
9ac4176b
PA
12525
12526 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12527
12528 if (!arg)
12529 arg = "";
b4a5b78b 12530 catch_ada_assert_command_split (arg, &cond_string);
761269c8 12531 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
b4a5b78b 12532 NULL, cond_string,
349774ef
JB
12533 tempflag, 1 /* enabled */,
12534 from_tty);
9ac4176b 12535}
778865d3
JB
12536
12537/* Return non-zero if the symbol SYM is an Ada exception object. */
12538
12539static int
12540ada_is_exception_sym (struct symbol *sym)
12541{
12542 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
12543
12544 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
12545 && SYMBOL_CLASS (sym) != LOC_BLOCK
12546 && SYMBOL_CLASS (sym) != LOC_CONST
12547 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
12548 && type_name != NULL && strcmp (type_name, "exception") == 0);
12549}
12550
12551/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12552 Ada exception object. This matches all exceptions except the ones
12553 defined by the Ada language. */
12554
12555static int
12556ada_is_non_standard_exception_sym (struct symbol *sym)
12557{
12558 int i;
12559
12560 if (!ada_is_exception_sym (sym))
12561 return 0;
12562
12563 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12564 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
12565 return 0; /* A standard exception. */
12566
12567 /* Numeric_Error is also a standard exception, so exclude it.
12568 See the STANDARD_EXC description for more details as to why
12569 this exception is not listed in that array. */
12570 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
12571 return 0;
12572
12573 return 1;
12574}
12575
12576/* A helper function for qsort, comparing two struct ada_exc_info
12577 objects.
12578
12579 The comparison is determined first by exception name, and then
12580 by exception address. */
12581
12582static int
12583compare_ada_exception_info (const void *a, const void *b)
12584{
12585 const struct ada_exc_info *exc_a = (struct ada_exc_info *) a;
12586 const struct ada_exc_info *exc_b = (struct ada_exc_info *) b;
12587 int result;
12588
12589 result = strcmp (exc_a->name, exc_b->name);
12590 if (result != 0)
12591 return result;
12592
12593 if (exc_a->addr < exc_b->addr)
12594 return -1;
12595 if (exc_a->addr > exc_b->addr)
12596 return 1;
12597
12598 return 0;
12599}
12600
12601/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12602 routine, but keeping the first SKIP elements untouched.
12603
12604 All duplicates are also removed. */
12605
12606static void
12607sort_remove_dups_ada_exceptions_list (VEC(ada_exc_info) **exceptions,
12608 int skip)
12609{
12610 struct ada_exc_info *to_sort
12611 = VEC_address (ada_exc_info, *exceptions) + skip;
12612 int to_sort_len
12613 = VEC_length (ada_exc_info, *exceptions) - skip;
12614 int i, j;
12615
12616 qsort (to_sort, to_sort_len, sizeof (struct ada_exc_info),
12617 compare_ada_exception_info);
12618
12619 for (i = 1, j = 1; i < to_sort_len; i++)
12620 if (compare_ada_exception_info (&to_sort[i], &to_sort[j - 1]) != 0)
12621 to_sort[j++] = to_sort[i];
12622 to_sort_len = j;
12623 VEC_truncate(ada_exc_info, *exceptions, skip + to_sort_len);
12624}
12625
12626/* A function intended as the "name_matcher" callback in the struct
12627 quick_symbol_functions' expand_symtabs_matching method.
12628
12629 SEARCH_NAME is the symbol's search name.
12630
12631 If USER_DATA is not NULL, it is a pointer to a regext_t object
12632 used to match the symbol (by natural name). Otherwise, when USER_DATA
12633 is null, no filtering is performed, and all symbols are a positive
12634 match. */
12635
12636static int
12637ada_exc_search_name_matches (const char *search_name, void *user_data)
12638{
12639 regex_t *preg = user_data;
12640
12641 if (preg == NULL)
12642 return 1;
12643
12644 /* In Ada, the symbol "search name" is a linkage name, whereas
12645 the regular expression used to do the matching refers to
12646 the natural name. So match against the decoded name. */
12647 return (regexec (preg, ada_decode (search_name), 0, NULL, 0) == 0);
12648}
12649
12650/* Add all exceptions defined by the Ada standard whose name match
12651 a regular expression.
12652
12653 If PREG is not NULL, then this regexp_t object is used to
12654 perform the symbol name matching. Otherwise, no name-based
12655 filtering is performed.
12656
12657 EXCEPTIONS is a vector of exceptions to which matching exceptions
12658 gets pushed. */
12659
12660static void
12661ada_add_standard_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
12662{
12663 int i;
12664
12665 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12666 {
12667 if (preg == NULL
12668 || regexec (preg, standard_exc[i], 0, NULL, 0) == 0)
12669 {
12670 struct bound_minimal_symbol msymbol
12671 = ada_lookup_simple_minsym (standard_exc[i]);
12672
12673 if (msymbol.minsym != NULL)
12674 {
12675 struct ada_exc_info info
efd66ac6 12676 = {standard_exc[i], MSYMBOL_VALUE_ADDRESS (msymbol.minsym)};
778865d3
JB
12677
12678 VEC_safe_push (ada_exc_info, *exceptions, &info);
12679 }
12680 }
12681 }
12682}
12683
12684/* Add all Ada exceptions defined locally and accessible from the given
12685 FRAME.
12686
12687 If PREG is not NULL, then this regexp_t object is used to
12688 perform the symbol name matching. Otherwise, no name-based
12689 filtering is performed.
12690
12691 EXCEPTIONS is a vector of exceptions to which matching exceptions
12692 gets pushed. */
12693
12694static void
12695ada_add_exceptions_from_frame (regex_t *preg, struct frame_info *frame,
12696 VEC(ada_exc_info) **exceptions)
12697{
12698 struct block *block = get_frame_block (frame, 0);
12699
12700 while (block != 0)
12701 {
12702 struct block_iterator iter;
12703 struct symbol *sym;
12704
12705 ALL_BLOCK_SYMBOLS (block, iter, sym)
12706 {
12707 switch (SYMBOL_CLASS (sym))
12708 {
12709 case LOC_TYPEDEF:
12710 case LOC_BLOCK:
12711 case LOC_CONST:
12712 break;
12713 default:
12714 if (ada_is_exception_sym (sym))
12715 {
12716 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
12717 SYMBOL_VALUE_ADDRESS (sym)};
12718
12719 VEC_safe_push (ada_exc_info, *exceptions, &info);
12720 }
12721 }
12722 }
12723 if (BLOCK_FUNCTION (block) != NULL)
12724 break;
12725 block = BLOCK_SUPERBLOCK (block);
12726 }
12727}
12728
12729/* Add all exceptions defined globally whose name name match
12730 a regular expression, excluding standard exceptions.
12731
12732 The reason we exclude standard exceptions is that they need
12733 to be handled separately: Standard exceptions are defined inside
12734 a runtime unit which is normally not compiled with debugging info,
12735 and thus usually do not show up in our symbol search. However,
12736 if the unit was in fact built with debugging info, we need to
12737 exclude them because they would duplicate the entry we found
12738 during the special loop that specifically searches for those
12739 standard exceptions.
12740
12741 If PREG is not NULL, then this regexp_t object is used to
12742 perform the symbol name matching. Otherwise, no name-based
12743 filtering is performed.
12744
12745 EXCEPTIONS is a vector of exceptions to which matching exceptions
12746 gets pushed. */
12747
12748static void
12749ada_add_global_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
12750{
12751 struct objfile *objfile;
12752 struct symtab *s;
12753
bb4142cf
DE
12754 expand_symtabs_matching (NULL, ada_exc_search_name_matches,
12755 VARIABLES_DOMAIN, preg);
778865d3
JB
12756
12757 ALL_PRIMARY_SYMTABS (objfile, s)
12758 {
12759 struct blockvector *bv = BLOCKVECTOR (s);
12760 int i;
12761
12762 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
12763 {
12764 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
12765 struct block_iterator iter;
12766 struct symbol *sym;
12767
12768 ALL_BLOCK_SYMBOLS (b, iter, sym)
12769 if (ada_is_non_standard_exception_sym (sym)
12770 && (preg == NULL
12771 || regexec (preg, SYMBOL_NATURAL_NAME (sym),
12772 0, NULL, 0) == 0))
12773 {
12774 struct ada_exc_info info
12775 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
12776
12777 VEC_safe_push (ada_exc_info, *exceptions, &info);
12778 }
12779 }
12780 }
12781}
12782
12783/* Implements ada_exceptions_list with the regular expression passed
12784 as a regex_t, rather than a string.
12785
12786 If not NULL, PREG is used to filter out exceptions whose names
12787 do not match. Otherwise, all exceptions are listed. */
12788
12789static VEC(ada_exc_info) *
12790ada_exceptions_list_1 (regex_t *preg)
12791{
12792 VEC(ada_exc_info) *result = NULL;
12793 struct cleanup *old_chain
12794 = make_cleanup (VEC_cleanup (ada_exc_info), &result);
12795 int prev_len;
12796
12797 /* First, list the known standard exceptions. These exceptions
12798 need to be handled separately, as they are usually defined in
12799 runtime units that have been compiled without debugging info. */
12800
12801 ada_add_standard_exceptions (preg, &result);
12802
12803 /* Next, find all exceptions whose scope is local and accessible
12804 from the currently selected frame. */
12805
12806 if (has_stack_frames ())
12807 {
12808 prev_len = VEC_length (ada_exc_info, result);
12809 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
12810 &result);
12811 if (VEC_length (ada_exc_info, result) > prev_len)
12812 sort_remove_dups_ada_exceptions_list (&result, prev_len);
12813 }
12814
12815 /* Add all exceptions whose scope is global. */
12816
12817 prev_len = VEC_length (ada_exc_info, result);
12818 ada_add_global_exceptions (preg, &result);
12819 if (VEC_length (ada_exc_info, result) > prev_len)
12820 sort_remove_dups_ada_exceptions_list (&result, prev_len);
12821
12822 discard_cleanups (old_chain);
12823 return result;
12824}
12825
12826/* Return a vector of ada_exc_info.
12827
12828 If REGEXP is NULL, all exceptions are included in the result.
12829 Otherwise, it should contain a valid regular expression,
12830 and only the exceptions whose names match that regular expression
12831 are included in the result.
12832
12833 The exceptions are sorted in the following order:
12834 - Standard exceptions (defined by the Ada language), in
12835 alphabetical order;
12836 - Exceptions only visible from the current frame, in
12837 alphabetical order;
12838 - Exceptions whose scope is global, in alphabetical order. */
12839
12840VEC(ada_exc_info) *
12841ada_exceptions_list (const char *regexp)
12842{
12843 VEC(ada_exc_info) *result = NULL;
12844 struct cleanup *old_chain = NULL;
12845 regex_t reg;
12846
12847 if (regexp != NULL)
12848 old_chain = compile_rx_or_error (&reg, regexp,
12849 _("invalid regular expression"));
12850
12851 result = ada_exceptions_list_1 (regexp != NULL ? &reg : NULL);
12852
12853 if (old_chain != NULL)
12854 do_cleanups (old_chain);
12855 return result;
12856}
12857
12858/* Implement the "info exceptions" command. */
12859
12860static void
12861info_exceptions_command (char *regexp, int from_tty)
12862{
12863 VEC(ada_exc_info) *exceptions;
12864 struct cleanup *cleanup;
12865 struct gdbarch *gdbarch = get_current_arch ();
12866 int ix;
12867 struct ada_exc_info *info;
12868
12869 exceptions = ada_exceptions_list (regexp);
12870 cleanup = make_cleanup (VEC_cleanup (ada_exc_info), &exceptions);
12871
12872 if (regexp != NULL)
12873 printf_filtered
12874 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
12875 else
12876 printf_filtered (_("All defined Ada exceptions:\n"));
12877
12878 for (ix = 0; VEC_iterate(ada_exc_info, exceptions, ix, info); ix++)
12879 printf_filtered ("%s: %s\n", info->name, paddress (gdbarch, info->addr));
12880
12881 do_cleanups (cleanup);
12882}
12883
4c4b4cd2
PH
12884 /* Operators */
12885/* Information about operators given special treatment in functions
12886 below. */
12887/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
12888
12889#define ADA_OPERATORS \
12890 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
12891 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
12892 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
12893 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
12894 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
12895 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
12896 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
12897 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
12898 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
12899 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
12900 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
12901 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
12902 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
12903 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
12904 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
12905 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
12906 OP_DEFN (OP_OTHERS, 1, 1, 0) \
12907 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
12908 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
12909
12910static void
554794dc
SDJ
12911ada_operator_length (const struct expression *exp, int pc, int *oplenp,
12912 int *argsp)
4c4b4cd2
PH
12913{
12914 switch (exp->elts[pc - 1].opcode)
12915 {
76a01679 12916 default:
4c4b4cd2
PH
12917 operator_length_standard (exp, pc, oplenp, argsp);
12918 break;
12919
12920#define OP_DEFN(op, len, args, binop) \
12921 case op: *oplenp = len; *argsp = args; break;
12922 ADA_OPERATORS;
12923#undef OP_DEFN
52ce6436
PH
12924
12925 case OP_AGGREGATE:
12926 *oplenp = 3;
12927 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
12928 break;
12929
12930 case OP_CHOICES:
12931 *oplenp = 3;
12932 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
12933 break;
4c4b4cd2
PH
12934 }
12935}
12936
c0201579
JK
12937/* Implementation of the exp_descriptor method operator_check. */
12938
12939static int
12940ada_operator_check (struct expression *exp, int pos,
12941 int (*objfile_func) (struct objfile *objfile, void *data),
12942 void *data)
12943{
12944 const union exp_element *const elts = exp->elts;
12945 struct type *type = NULL;
12946
12947 switch (elts[pos].opcode)
12948 {
12949 case UNOP_IN_RANGE:
12950 case UNOP_QUAL:
12951 type = elts[pos + 1].type;
12952 break;
12953
12954 default:
12955 return operator_check_standard (exp, pos, objfile_func, data);
12956 }
12957
12958 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
12959
12960 if (type && TYPE_OBJFILE (type)
12961 && (*objfile_func) (TYPE_OBJFILE (type), data))
12962 return 1;
12963
12964 return 0;
12965}
12966
4c4b4cd2
PH
12967static char *
12968ada_op_name (enum exp_opcode opcode)
12969{
12970 switch (opcode)
12971 {
76a01679 12972 default:
4c4b4cd2 12973 return op_name_standard (opcode);
52ce6436 12974
4c4b4cd2
PH
12975#define OP_DEFN(op, len, args, binop) case op: return #op;
12976 ADA_OPERATORS;
12977#undef OP_DEFN
52ce6436
PH
12978
12979 case OP_AGGREGATE:
12980 return "OP_AGGREGATE";
12981 case OP_CHOICES:
12982 return "OP_CHOICES";
12983 case OP_NAME:
12984 return "OP_NAME";
4c4b4cd2
PH
12985 }
12986}
12987
12988/* As for operator_length, but assumes PC is pointing at the first
12989 element of the operator, and gives meaningful results only for the
52ce6436 12990 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
12991
12992static void
76a01679
JB
12993ada_forward_operator_length (struct expression *exp, int pc,
12994 int *oplenp, int *argsp)
4c4b4cd2 12995{
76a01679 12996 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
12997 {
12998 default:
12999 *oplenp = *argsp = 0;
13000 break;
52ce6436 13001
4c4b4cd2
PH
13002#define OP_DEFN(op, len, args, binop) \
13003 case op: *oplenp = len; *argsp = args; break;
13004 ADA_OPERATORS;
13005#undef OP_DEFN
52ce6436
PH
13006
13007 case OP_AGGREGATE:
13008 *oplenp = 3;
13009 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13010 break;
13011
13012 case OP_CHOICES:
13013 *oplenp = 3;
13014 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13015 break;
13016
13017 case OP_STRING:
13018 case OP_NAME:
13019 {
13020 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13021
52ce6436
PH
13022 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13023 *argsp = 0;
13024 break;
13025 }
4c4b4cd2
PH
13026 }
13027}
13028
13029static int
13030ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13031{
13032 enum exp_opcode op = exp->elts[elt].opcode;
13033 int oplen, nargs;
13034 int pc = elt;
13035 int i;
76a01679 13036
4c4b4cd2
PH
13037 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13038
76a01679 13039 switch (op)
4c4b4cd2 13040 {
76a01679 13041 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13042 case OP_ATR_FIRST:
13043 case OP_ATR_LAST:
13044 case OP_ATR_LENGTH:
13045 case OP_ATR_IMAGE:
13046 case OP_ATR_MAX:
13047 case OP_ATR_MIN:
13048 case OP_ATR_MODULUS:
13049 case OP_ATR_POS:
13050 case OP_ATR_SIZE:
13051 case OP_ATR_TAG:
13052 case OP_ATR_VAL:
13053 break;
13054
13055 case UNOP_IN_RANGE:
13056 case UNOP_QUAL:
323e0a4a
AC
13057 /* XXX: gdb_sprint_host_address, type_sprint */
13058 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13059 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13060 fprintf_filtered (stream, " (");
13061 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13062 fprintf_filtered (stream, ")");
13063 break;
13064 case BINOP_IN_BOUNDS:
52ce6436
PH
13065 fprintf_filtered (stream, " (%d)",
13066 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13067 break;
13068 case TERNOP_IN_RANGE:
13069 break;
13070
52ce6436
PH
13071 case OP_AGGREGATE:
13072 case OP_OTHERS:
13073 case OP_DISCRETE_RANGE:
13074 case OP_POSITIONAL:
13075 case OP_CHOICES:
13076 break;
13077
13078 case OP_NAME:
13079 case OP_STRING:
13080 {
13081 char *name = &exp->elts[elt + 2].string;
13082 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 13083
52ce6436
PH
13084 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13085 break;
13086 }
13087
4c4b4cd2
PH
13088 default:
13089 return dump_subexp_body_standard (exp, stream, elt);
13090 }
13091
13092 elt += oplen;
13093 for (i = 0; i < nargs; i += 1)
13094 elt = dump_subexp (exp, stream, elt);
13095
13096 return elt;
13097}
13098
13099/* The Ada extension of print_subexp (q.v.). */
13100
76a01679
JB
13101static void
13102ada_print_subexp (struct expression *exp, int *pos,
13103 struct ui_file *stream, enum precedence prec)
4c4b4cd2 13104{
52ce6436 13105 int oplen, nargs, i;
4c4b4cd2
PH
13106 int pc = *pos;
13107 enum exp_opcode op = exp->elts[pc].opcode;
13108
13109 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13110
52ce6436 13111 *pos += oplen;
4c4b4cd2
PH
13112 switch (op)
13113 {
13114 default:
52ce6436 13115 *pos -= oplen;
4c4b4cd2
PH
13116 print_subexp_standard (exp, pos, stream, prec);
13117 return;
13118
13119 case OP_VAR_VALUE:
4c4b4cd2
PH
13120 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13121 return;
13122
13123 case BINOP_IN_BOUNDS:
323e0a4a 13124 /* XXX: sprint_subexp */
4c4b4cd2 13125 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13126 fputs_filtered (" in ", stream);
4c4b4cd2 13127 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13128 fputs_filtered ("'range", stream);
4c4b4cd2 13129 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
13130 fprintf_filtered (stream, "(%ld)",
13131 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
13132 return;
13133
13134 case TERNOP_IN_RANGE:
4c4b4cd2 13135 if (prec >= PREC_EQUAL)
76a01679 13136 fputs_filtered ("(", stream);
323e0a4a 13137 /* XXX: sprint_subexp */
4c4b4cd2 13138 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13139 fputs_filtered (" in ", stream);
4c4b4cd2
PH
13140 print_subexp (exp, pos, stream, PREC_EQUAL);
13141 fputs_filtered (" .. ", stream);
13142 print_subexp (exp, pos, stream, PREC_EQUAL);
13143 if (prec >= PREC_EQUAL)
76a01679
JB
13144 fputs_filtered (")", stream);
13145 return;
4c4b4cd2
PH
13146
13147 case OP_ATR_FIRST:
13148 case OP_ATR_LAST:
13149 case OP_ATR_LENGTH:
13150 case OP_ATR_IMAGE:
13151 case OP_ATR_MAX:
13152 case OP_ATR_MIN:
13153 case OP_ATR_MODULUS:
13154 case OP_ATR_POS:
13155 case OP_ATR_SIZE:
13156 case OP_ATR_TAG:
13157 case OP_ATR_VAL:
4c4b4cd2 13158 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
13159 {
13160 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
13161 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13162 &type_print_raw_options);
76a01679
JB
13163 *pos += 3;
13164 }
4c4b4cd2 13165 else
76a01679 13166 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
13167 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13168 if (nargs > 1)
76a01679
JB
13169 {
13170 int tem;
5b4ee69b 13171
76a01679
JB
13172 for (tem = 1; tem < nargs; tem += 1)
13173 {
13174 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13175 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13176 }
13177 fputs_filtered (")", stream);
13178 }
4c4b4cd2 13179 return;
14f9c5c9 13180
4c4b4cd2 13181 case UNOP_QUAL:
4c4b4cd2
PH
13182 type_print (exp->elts[pc + 1].type, "", stream, 0);
13183 fputs_filtered ("'(", stream);
13184 print_subexp (exp, pos, stream, PREC_PREFIX);
13185 fputs_filtered (")", stream);
13186 return;
14f9c5c9 13187
4c4b4cd2 13188 case UNOP_IN_RANGE:
323e0a4a 13189 /* XXX: sprint_subexp */
4c4b4cd2 13190 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13191 fputs_filtered (" in ", stream);
79d43c61
TT
13192 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13193 &type_print_raw_options);
4c4b4cd2 13194 return;
52ce6436
PH
13195
13196 case OP_DISCRETE_RANGE:
13197 print_subexp (exp, pos, stream, PREC_SUFFIX);
13198 fputs_filtered ("..", stream);
13199 print_subexp (exp, pos, stream, PREC_SUFFIX);
13200 return;
13201
13202 case OP_OTHERS:
13203 fputs_filtered ("others => ", stream);
13204 print_subexp (exp, pos, stream, PREC_SUFFIX);
13205 return;
13206
13207 case OP_CHOICES:
13208 for (i = 0; i < nargs-1; i += 1)
13209 {
13210 if (i > 0)
13211 fputs_filtered ("|", stream);
13212 print_subexp (exp, pos, stream, PREC_SUFFIX);
13213 }
13214 fputs_filtered (" => ", stream);
13215 print_subexp (exp, pos, stream, PREC_SUFFIX);
13216 return;
13217
13218 case OP_POSITIONAL:
13219 print_subexp (exp, pos, stream, PREC_SUFFIX);
13220 return;
13221
13222 case OP_AGGREGATE:
13223 fputs_filtered ("(", stream);
13224 for (i = 0; i < nargs; i += 1)
13225 {
13226 if (i > 0)
13227 fputs_filtered (", ", stream);
13228 print_subexp (exp, pos, stream, PREC_SUFFIX);
13229 }
13230 fputs_filtered (")", stream);
13231 return;
4c4b4cd2
PH
13232 }
13233}
14f9c5c9
AS
13234
13235/* Table mapping opcodes into strings for printing operators
13236 and precedences of the operators. */
13237
d2e4a39e
AS
13238static const struct op_print ada_op_print_tab[] = {
13239 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13240 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13241 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13242 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13243 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13244 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13245 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13246 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13247 {"<=", BINOP_LEQ, PREC_ORDER, 0},
13248 {">=", BINOP_GEQ, PREC_ORDER, 0},
13249 {">", BINOP_GTR, PREC_ORDER, 0},
13250 {"<", BINOP_LESS, PREC_ORDER, 0},
13251 {">>", BINOP_RSH, PREC_SHIFT, 0},
13252 {"<<", BINOP_LSH, PREC_SHIFT, 0},
13253 {"+", BINOP_ADD, PREC_ADD, 0},
13254 {"-", BINOP_SUB, PREC_ADD, 0},
13255 {"&", BINOP_CONCAT, PREC_ADD, 0},
13256 {"*", BINOP_MUL, PREC_MUL, 0},
13257 {"/", BINOP_DIV, PREC_MUL, 0},
13258 {"rem", BINOP_REM, PREC_MUL, 0},
13259 {"mod", BINOP_MOD, PREC_MUL, 0},
13260 {"**", BINOP_EXP, PREC_REPEAT, 0},
13261 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13262 {"-", UNOP_NEG, PREC_PREFIX, 0},
13263 {"+", UNOP_PLUS, PREC_PREFIX, 0},
13264 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13265 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13266 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
13267 {".all", UNOP_IND, PREC_SUFFIX, 1},
13268 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13269 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
d2e4a39e 13270 {NULL, 0, 0, 0}
14f9c5c9
AS
13271};
13272\f
72d5681a
PH
13273enum ada_primitive_types {
13274 ada_primitive_type_int,
13275 ada_primitive_type_long,
13276 ada_primitive_type_short,
13277 ada_primitive_type_char,
13278 ada_primitive_type_float,
13279 ada_primitive_type_double,
13280 ada_primitive_type_void,
13281 ada_primitive_type_long_long,
13282 ada_primitive_type_long_double,
13283 ada_primitive_type_natural,
13284 ada_primitive_type_positive,
13285 ada_primitive_type_system_address,
13286 nr_ada_primitive_types
13287};
6c038f32
PH
13288
13289static void
d4a9a881 13290ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
13291 struct language_arch_info *lai)
13292{
d4a9a881 13293 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 13294
72d5681a 13295 lai->primitive_type_vector
d4a9a881 13296 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 13297 struct type *);
e9bb382b
UW
13298
13299 lai->primitive_type_vector [ada_primitive_type_int]
13300 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13301 0, "integer");
13302 lai->primitive_type_vector [ada_primitive_type_long]
13303 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13304 0, "long_integer");
13305 lai->primitive_type_vector [ada_primitive_type_short]
13306 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13307 0, "short_integer");
13308 lai->string_char_type
13309 = lai->primitive_type_vector [ada_primitive_type_char]
13310 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
13311 lai->primitive_type_vector [ada_primitive_type_float]
13312 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13313 "float", NULL);
13314 lai->primitive_type_vector [ada_primitive_type_double]
13315 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13316 "long_float", NULL);
13317 lai->primitive_type_vector [ada_primitive_type_long_long]
13318 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13319 0, "long_long_integer");
13320 lai->primitive_type_vector [ada_primitive_type_long_double]
13321 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13322 "long_long_float", NULL);
13323 lai->primitive_type_vector [ada_primitive_type_natural]
13324 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13325 0, "natural");
13326 lai->primitive_type_vector [ada_primitive_type_positive]
13327 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13328 0, "positive");
13329 lai->primitive_type_vector [ada_primitive_type_void]
13330 = builtin->builtin_void;
13331
13332 lai->primitive_type_vector [ada_primitive_type_system_address]
13333 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
72d5681a
PH
13334 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
13335 = "system__address";
fbb06eb1 13336
47e729a8 13337 lai->bool_type_symbol = NULL;
fbb06eb1 13338 lai->bool_type_default = builtin->builtin_bool;
6c038f32 13339}
6c038f32
PH
13340\f
13341 /* Language vector */
13342
13343/* Not really used, but needed in the ada_language_defn. */
13344
13345static void
6c7a06a3 13346emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 13347{
6c7a06a3 13348 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
13349}
13350
13351static int
13352parse (void)
13353{
13354 warnings_issued = 0;
13355 return ada_parse ();
13356}
13357
13358static const struct exp_descriptor ada_exp_descriptor = {
13359 ada_print_subexp,
13360 ada_operator_length,
c0201579 13361 ada_operator_check,
6c038f32
PH
13362 ada_op_name,
13363 ada_dump_subexp_body,
13364 ada_evaluate_subexp
13365};
13366
1a119f36 13367/* Implement the "la_get_symbol_name_cmp" language_defn method
74ccd7f5
JB
13368 for Ada. */
13369
1a119f36
JB
13370static symbol_name_cmp_ftype
13371ada_get_symbol_name_cmp (const char *lookup_name)
74ccd7f5
JB
13372{
13373 if (should_use_wild_match (lookup_name))
13374 return wild_match;
13375 else
13376 return compare_names;
13377}
13378
a5ee536b
JB
13379/* Implement the "la_read_var_value" language_defn method for Ada. */
13380
13381static struct value *
13382ada_read_var_value (struct symbol *var, struct frame_info *frame)
13383{
13384 struct block *frame_block = NULL;
13385 struct symbol *renaming_sym = NULL;
13386
13387 /* The only case where default_read_var_value is not sufficient
13388 is when VAR is a renaming... */
13389 if (frame)
13390 frame_block = get_frame_block (frame, NULL);
13391 if (frame_block)
13392 renaming_sym = ada_find_renaming_symbol (var, frame_block);
13393 if (renaming_sym != NULL)
13394 return ada_read_renaming_var_value (renaming_sym, frame_block);
13395
13396 /* This is a typical case where we expect the default_read_var_value
13397 function to work. */
13398 return default_read_var_value (var, frame);
13399}
13400
6c038f32
PH
13401const struct language_defn ada_language_defn = {
13402 "ada", /* Language name */
6abde28f 13403 "Ada",
6c038f32 13404 language_ada,
6c038f32 13405 range_check_off,
6c038f32
PH
13406 case_sensitive_on, /* Yes, Ada is case-insensitive, but
13407 that's not quite what this means. */
6c038f32 13408 array_row_major,
9a044a89 13409 macro_expansion_no,
6c038f32
PH
13410 &ada_exp_descriptor,
13411 parse,
13412 ada_error,
13413 resolve,
13414 ada_printchar, /* Print a character constant */
13415 ada_printstr, /* Function to print string constant */
13416 emit_char, /* Function to print single char (not used) */
6c038f32 13417 ada_print_type, /* Print a type using appropriate syntax */
be942545 13418 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
13419 ada_val_print, /* Print a value using appropriate syntax */
13420 ada_value_print, /* Print a top-level value */
a5ee536b 13421 ada_read_var_value, /* la_read_var_value */
6c038f32 13422 NULL, /* Language specific skip_trampoline */
2b2d9e11 13423 NULL, /* name_of_this */
6c038f32
PH
13424 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
13425 basic_lookup_transparent_type, /* lookup_transparent_type */
13426 ada_la_decode, /* Language specific symbol demangler */
0963b4bd
MS
13427 NULL, /* Language specific
13428 class_name_from_physname */
6c038f32
PH
13429 ada_op_print_tab, /* expression operators for printing */
13430 0, /* c-style arrays */
13431 1, /* String lower bound */
6c038f32 13432 ada_get_gdb_completer_word_break_characters,
41d27058 13433 ada_make_symbol_completion_list,
72d5681a 13434 ada_language_arch_info,
e79af960 13435 ada_print_array_index,
41f1b697 13436 default_pass_by_reference,
ae6a3a4c 13437 c_get_string,
1a119f36 13438 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
f8eba3c6 13439 ada_iterate_over_symbols,
a53b64ea 13440 &ada_varobj_ops,
6c038f32
PH
13441 LANG_MAGIC
13442};
13443
2c0b251b
PA
13444/* Provide a prototype to silence -Wmissing-prototypes. */
13445extern initialize_file_ftype _initialize_ada_language;
13446
5bf03f13
JB
13447/* Command-list for the "set/show ada" prefix command. */
13448static struct cmd_list_element *set_ada_list;
13449static struct cmd_list_element *show_ada_list;
13450
13451/* Implement the "set ada" prefix command. */
13452
13453static void
13454set_ada_command (char *arg, int from_tty)
13455{
13456 printf_unfiltered (_(\
13457"\"set ada\" must be followed by the name of a setting.\n"));
13458 help_list (set_ada_list, "set ada ", -1, gdb_stdout);
13459}
13460
13461/* Implement the "show ada" prefix command. */
13462
13463static void
13464show_ada_command (char *args, int from_tty)
13465{
13466 cmd_show_list (show_ada_list, from_tty, "");
13467}
13468
2060206e
PA
13469static void
13470initialize_ada_catchpoint_ops (void)
13471{
13472 struct breakpoint_ops *ops;
13473
13474 initialize_breakpoint_ops ();
13475
13476 ops = &catch_exception_breakpoint_ops;
13477 *ops = bkpt_breakpoint_ops;
13478 ops->dtor = dtor_catch_exception;
13479 ops->allocate_location = allocate_location_catch_exception;
13480 ops->re_set = re_set_catch_exception;
13481 ops->check_status = check_status_catch_exception;
13482 ops->print_it = print_it_catch_exception;
13483 ops->print_one = print_one_catch_exception;
13484 ops->print_mention = print_mention_catch_exception;
13485 ops->print_recreate = print_recreate_catch_exception;
13486
13487 ops = &catch_exception_unhandled_breakpoint_ops;
13488 *ops = bkpt_breakpoint_ops;
13489 ops->dtor = dtor_catch_exception_unhandled;
13490 ops->allocate_location = allocate_location_catch_exception_unhandled;
13491 ops->re_set = re_set_catch_exception_unhandled;
13492 ops->check_status = check_status_catch_exception_unhandled;
13493 ops->print_it = print_it_catch_exception_unhandled;
13494 ops->print_one = print_one_catch_exception_unhandled;
13495 ops->print_mention = print_mention_catch_exception_unhandled;
13496 ops->print_recreate = print_recreate_catch_exception_unhandled;
13497
13498 ops = &catch_assert_breakpoint_ops;
13499 *ops = bkpt_breakpoint_ops;
13500 ops->dtor = dtor_catch_assert;
13501 ops->allocate_location = allocate_location_catch_assert;
13502 ops->re_set = re_set_catch_assert;
13503 ops->check_status = check_status_catch_assert;
13504 ops->print_it = print_it_catch_assert;
13505 ops->print_one = print_one_catch_assert;
13506 ops->print_mention = print_mention_catch_assert;
13507 ops->print_recreate = print_recreate_catch_assert;
13508}
13509
3d9434b5
JB
13510/* This module's 'new_objfile' observer. */
13511
13512static void
13513ada_new_objfile_observer (struct objfile *objfile)
13514{
13515 ada_clear_symbol_cache ();
13516}
13517
13518/* This module's 'free_objfile' observer. */
13519
13520static void
13521ada_free_objfile_observer (struct objfile *objfile)
13522{
13523 ada_clear_symbol_cache ();
13524}
13525
d2e4a39e 13526void
6c038f32 13527_initialize_ada_language (void)
14f9c5c9 13528{
6c038f32
PH
13529 add_language (&ada_language_defn);
13530
2060206e
PA
13531 initialize_ada_catchpoint_ops ();
13532
5bf03f13
JB
13533 add_prefix_cmd ("ada", no_class, set_ada_command,
13534 _("Prefix command for changing Ada-specfic settings"),
13535 &set_ada_list, "set ada ", 0, &setlist);
13536
13537 add_prefix_cmd ("ada", no_class, show_ada_command,
13538 _("Generic command for showing Ada-specific settings."),
13539 &show_ada_list, "show ada ", 0, &showlist);
13540
13541 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13542 &trust_pad_over_xvs, _("\
13543Enable or disable an optimization trusting PAD types over XVS types"), _("\
13544Show whether an optimization trusting PAD types over XVS types is activated"),
13545 _("\
13546This is related to the encoding used by the GNAT compiler. The debugger\n\
13547should normally trust the contents of PAD types, but certain older versions\n\
13548of GNAT have a bug that sometimes causes the information in the PAD type\n\
13549to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13550work around this bug. It is always safe to turn this option \"off\", but\n\
13551this incurs a slight performance penalty, so it is recommended to NOT change\n\
13552this option to \"off\" unless necessary."),
13553 NULL, NULL, &set_ada_list, &show_ada_list);
13554
9ac4176b
PA
13555 add_catch_command ("exception", _("\
13556Catch Ada exceptions, when raised.\n\
13557With an argument, catch only exceptions with the given name."),
13558 catch_ada_exception_command,
13559 NULL,
13560 CATCH_PERMANENT,
13561 CATCH_TEMPORARY);
13562 add_catch_command ("assert", _("\
13563Catch failed Ada assertions, when raised.\n\
13564With an argument, catch only exceptions with the given name."),
13565 catch_assert_command,
13566 NULL,
13567 CATCH_PERMANENT,
13568 CATCH_TEMPORARY);
13569
6c038f32 13570 varsize_limit = 65536;
6c038f32 13571
778865d3
JB
13572 add_info ("exceptions", info_exceptions_command,
13573 _("\
13574List all Ada exception names.\n\
13575If a regular expression is passed as an argument, only those matching\n\
13576the regular expression are listed."));
13577
c6044dd1
JB
13578 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
13579 _("Set Ada maintenance-related variables."),
13580 &maint_set_ada_cmdlist, "maintenance set ada ",
13581 0/*allow-unknown*/, &maintenance_set_cmdlist);
13582
13583 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
13584 _("Show Ada maintenance-related variables"),
13585 &maint_show_ada_cmdlist, "maintenance show ada ",
13586 0/*allow-unknown*/, &maintenance_show_cmdlist);
13587
13588 add_setshow_boolean_cmd
13589 ("ignore-descriptive-types", class_maintenance,
13590 &ada_ignore_descriptive_types_p,
13591 _("Set whether descriptive types generated by GNAT should be ignored."),
13592 _("Show whether descriptive types generated by GNAT should be ignored."),
13593 _("\
13594When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13595DWARF attribute."),
13596 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
13597
6c038f32
PH
13598 obstack_init (&symbol_list_obstack);
13599
13600 decoded_names_store = htab_create_alloc
13601 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
13602 NULL, xcalloc, xfree);
6b69afc4 13603
3d9434b5
JB
13604 /* The ada-lang observers. */
13605 observer_attach_new_objfile (ada_new_objfile_observer);
13606 observer_attach_free_objfile (ada_free_objfile_observer);
e802dbe0 13607 observer_attach_inferior_exit (ada_inferior_exit);
ee01b665
JB
13608
13609 /* Setup various context-specific data. */
e802dbe0 13610 ada_inferior_data
8e260fc0 13611 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
ee01b665
JB
13612 ada_pspace_data_handle
13613 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14f9c5c9 13614}