]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
Minor style change in the previous commits' ChangeLog entry.
[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
77e371c0 925 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
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 9880 int pc;
5ec18f2b 9881 int preeval_pos;
14f9c5c9
AS
9882 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
9883 struct type *type;
52ce6436 9884 int nargs, oplen;
d2e4a39e 9885 struct value **argvec;
14f9c5c9 9886
d2e4a39e
AS
9887 pc = *pos;
9888 *pos += 1;
14f9c5c9
AS
9889 op = exp->elts[pc].opcode;
9890
d2e4a39e 9891 switch (op)
14f9c5c9
AS
9892 {
9893 default:
9894 *pos -= 1;
6e48bd2c 9895 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
9896
9897 if (noside == EVAL_NORMAL)
9898 arg1 = unwrap_value (arg1);
6e48bd2c
JB
9899
9900 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
9901 then we need to perform the conversion manually, because
9902 evaluate_subexp_standard doesn't do it. This conversion is
9903 necessary in Ada because the different kinds of float/fixed
9904 types in Ada have different representations.
9905
9906 Similarly, we need to perform the conversion from OP_LONG
9907 ourselves. */
9908 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
9909 arg1 = ada_value_cast (expect_type, arg1, noside);
9910
9911 return arg1;
4c4b4cd2
PH
9912
9913 case OP_STRING:
9914 {
76a01679 9915 struct value *result;
5b4ee69b 9916
76a01679
JB
9917 *pos -= 1;
9918 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
9919 /* The result type will have code OP_STRING, bashed there from
9920 OP_ARRAY. Bash it back. */
df407dfe
AC
9921 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
9922 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 9923 return result;
4c4b4cd2 9924 }
14f9c5c9
AS
9925
9926 case UNOP_CAST:
9927 (*pos) += 2;
9928 type = exp->elts[pc + 1].type;
9929 arg1 = evaluate_subexp (type, exp, pos, noside);
9930 if (noside == EVAL_SKIP)
4c4b4cd2 9931 goto nosideret;
6e48bd2c 9932 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
9933 return arg1;
9934
4c4b4cd2
PH
9935 case UNOP_QUAL:
9936 (*pos) += 2;
9937 type = exp->elts[pc + 1].type;
9938 return ada_evaluate_subexp (type, exp, pos, noside);
9939
14f9c5c9
AS
9940 case BINOP_ASSIGN:
9941 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
9942 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9943 {
9944 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
9945 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
9946 return arg1;
9947 return ada_value_assign (arg1, arg1);
9948 }
003f3813
JB
9949 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9950 except if the lhs of our assignment is a convenience variable.
9951 In the case of assigning to a convenience variable, the lhs
9952 should be exactly the result of the evaluation of the rhs. */
9953 type = value_type (arg1);
9954 if (VALUE_LVAL (arg1) == lval_internalvar)
9955 type = NULL;
9956 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 9957 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 9958 return arg1;
df407dfe
AC
9959 if (ada_is_fixed_point_type (value_type (arg1)))
9960 arg2 = cast_to_fixed (value_type (arg1), arg2);
9961 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 9962 error
323e0a4a 9963 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 9964 else
df407dfe 9965 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 9966 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
9967
9968 case BINOP_ADD:
9969 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9970 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9971 if (noside == EVAL_SKIP)
4c4b4cd2 9972 goto nosideret;
2ac8a782
JB
9973 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9974 return (value_from_longest
9975 (value_type (arg1),
9976 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
9977 if ((ada_is_fixed_point_type (value_type (arg1))
9978 || ada_is_fixed_point_type (value_type (arg2)))
9979 && value_type (arg1) != value_type (arg2))
323e0a4a 9980 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
9981 /* Do the addition, and cast the result to the type of the first
9982 argument. We cannot cast the result to a reference type, so if
9983 ARG1 is a reference type, find its underlying type. */
9984 type = value_type (arg1);
9985 while (TYPE_CODE (type) == TYPE_CODE_REF)
9986 type = TYPE_TARGET_TYPE (type);
f44316fa 9987 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 9988 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
9989
9990 case BINOP_SUB:
9991 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9992 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9993 if (noside == EVAL_SKIP)
4c4b4cd2 9994 goto nosideret;
2ac8a782
JB
9995 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9996 return (value_from_longest
9997 (value_type (arg1),
9998 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
9999 if ((ada_is_fixed_point_type (value_type (arg1))
10000 || ada_is_fixed_point_type (value_type (arg2)))
10001 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10002 error (_("Operands of fixed-point subtraction "
10003 "must have the same type"));
b7789565
JB
10004 /* Do the substraction, and cast the result to the type of the first
10005 argument. We cannot cast the result to a reference type, so if
10006 ARG1 is a reference type, find its underlying type. */
10007 type = value_type (arg1);
10008 while (TYPE_CODE (type) == TYPE_CODE_REF)
10009 type = TYPE_TARGET_TYPE (type);
f44316fa 10010 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10011 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10012
10013 case BINOP_MUL:
10014 case BINOP_DIV:
e1578042
JB
10015 case BINOP_REM:
10016 case BINOP_MOD:
14f9c5c9
AS
10017 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10018 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10019 if (noside == EVAL_SKIP)
4c4b4cd2 10020 goto nosideret;
e1578042 10021 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10022 {
10023 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10024 return value_zero (value_type (arg1), not_lval);
10025 }
14f9c5c9 10026 else
4c4b4cd2 10027 {
a53b7a21 10028 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10029 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10030 arg1 = cast_from_fixed (type, arg1);
df407dfe 10031 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10032 arg2 = cast_from_fixed (type, arg2);
f44316fa 10033 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10034 return ada_value_binop (arg1, arg2, op);
10035 }
10036
4c4b4cd2
PH
10037 case BINOP_EQUAL:
10038 case BINOP_NOTEQUAL:
14f9c5c9 10039 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10040 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10041 if (noside == EVAL_SKIP)
76a01679 10042 goto nosideret;
4c4b4cd2 10043 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10044 tem = 0;
4c4b4cd2 10045 else
f44316fa
UW
10046 {
10047 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10048 tem = ada_value_equal (arg1, arg2);
10049 }
4c4b4cd2 10050 if (op == BINOP_NOTEQUAL)
76a01679 10051 tem = !tem;
fbb06eb1
UW
10052 type = language_bool_type (exp->language_defn, exp->gdbarch);
10053 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10054
10055 case UNOP_NEG:
10056 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10057 if (noside == EVAL_SKIP)
10058 goto nosideret;
df407dfe
AC
10059 else if (ada_is_fixed_point_type (value_type (arg1)))
10060 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10061 else
f44316fa
UW
10062 {
10063 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10064 return value_neg (arg1);
10065 }
4c4b4cd2 10066
2330c6c6
JB
10067 case BINOP_LOGICAL_AND:
10068 case BINOP_LOGICAL_OR:
10069 case UNOP_LOGICAL_NOT:
000d5124
JB
10070 {
10071 struct value *val;
10072
10073 *pos -= 1;
10074 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10075 type = language_bool_type (exp->language_defn, exp->gdbarch);
10076 return value_cast (type, val);
000d5124 10077 }
2330c6c6
JB
10078
10079 case BINOP_BITWISE_AND:
10080 case BINOP_BITWISE_IOR:
10081 case BINOP_BITWISE_XOR:
000d5124
JB
10082 {
10083 struct value *val;
10084
10085 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10086 *pos = pc;
10087 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10088
10089 return value_cast (value_type (arg1), val);
10090 }
2330c6c6 10091
14f9c5c9
AS
10092 case OP_VAR_VALUE:
10093 *pos -= 1;
6799def4 10094
14f9c5c9 10095 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10096 {
10097 *pos += 4;
10098 goto nosideret;
10099 }
10100 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10101 /* Only encountered when an unresolved symbol occurs in a
10102 context other than a function call, in which case, it is
52ce6436 10103 invalid. */
323e0a4a 10104 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10105 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
14f9c5c9 10106 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10107 {
0c1f74cf 10108 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10109 /* Check to see if this is a tagged type. We also need to handle
10110 the case where the type is a reference to a tagged type, but
10111 we have to be careful to exclude pointers to tagged types.
10112 The latter should be shown as usual (as a pointer), whereas
10113 a reference should mostly be transparent to the user. */
10114 if (ada_is_tagged_type (type, 0)
10115 || (TYPE_CODE(type) == TYPE_CODE_REF
10116 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0c1f74cf
JB
10117 {
10118 /* Tagged types are a little special in the fact that the real
10119 type is dynamic and can only be determined by inspecting the
10120 object's tag. This means that we need to get the object's
10121 value first (EVAL_NORMAL) and then extract the actual object
10122 type from its tag.
10123
10124 Note that we cannot skip the final step where we extract
10125 the object type from its tag, because the EVAL_NORMAL phase
10126 results in dynamic components being resolved into fixed ones.
10127 This can cause problems when trying to print the type
10128 description of tagged types whose parent has a dynamic size:
10129 We use the type name of the "_parent" component in order
10130 to print the name of the ancestor type in the type description.
10131 If that component had a dynamic size, the resolution into
10132 a fixed type would result in the loss of that type name,
10133 thus preventing us from printing the name of the ancestor
10134 type in the type description. */
10135 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
b50d69b5
JG
10136
10137 if (TYPE_CODE (type) != TYPE_CODE_REF)
10138 {
10139 struct type *actual_type;
10140
10141 actual_type = type_from_tag (ada_value_tag (arg1));
10142 if (actual_type == NULL)
10143 /* If, for some reason, we were unable to determine
10144 the actual type from the tag, then use the static
10145 approximation that we just computed as a fallback.
10146 This can happen if the debugging information is
10147 incomplete, for instance. */
10148 actual_type = type;
10149 return value_zero (actual_type, not_lval);
10150 }
10151 else
10152 {
10153 /* In the case of a ref, ada_coerce_ref takes care
10154 of determining the actual type. But the evaluation
10155 should return a ref as it should be valid to ask
10156 for its address; so rebuild a ref after coerce. */
10157 arg1 = ada_coerce_ref (arg1);
10158 return value_ref (arg1);
10159 }
0c1f74cf
JB
10160 }
10161
4c4b4cd2
PH
10162 *pos += 4;
10163 return value_zero
10164 (to_static_fixed_type
10165 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
10166 not_lval);
10167 }
d2e4a39e 10168 else
4c4b4cd2 10169 {
284614f0 10170 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
4c4b4cd2
PH
10171 return ada_to_fixed_value (arg1);
10172 }
10173
10174 case OP_FUNCALL:
10175 (*pos) += 2;
10176
10177 /* Allocate arg vector, including space for the function to be
10178 called in argvec[0] and a terminating NULL. */
10179 nargs = longest_to_int (exp->elts[pc + 1].longconst);
10180 argvec =
10181 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
10182
10183 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10184 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10185 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10186 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10187 else
10188 {
10189 for (tem = 0; tem <= nargs; tem += 1)
10190 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10191 argvec[tem] = 0;
10192
10193 if (noside == EVAL_SKIP)
10194 goto nosideret;
10195 }
10196
ad82864c
JB
10197 if (ada_is_constrained_packed_array_type
10198 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10199 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10200 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10201 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10202 /* This is a packed array that has already been fixed, and
10203 therefore already coerced to a simple array. Nothing further
10204 to do. */
10205 ;
df407dfe
AC
10206 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
10207 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
76a01679 10208 && VALUE_LVAL (argvec[0]) == lval_memory))
4c4b4cd2
PH
10209 argvec[0] = value_addr (argvec[0]);
10210
df407dfe 10211 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10212
10213 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10214 them. So, if this is an array typedef (encoding use for array
10215 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10216 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10217 type = ada_typedef_target_type (type);
10218
4c4b4cd2
PH
10219 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10220 {
61ee279c 10221 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10222 {
10223 case TYPE_CODE_FUNC:
61ee279c 10224 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10225 break;
10226 case TYPE_CODE_ARRAY:
10227 break;
10228 case TYPE_CODE_STRUCT:
10229 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10230 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10231 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10232 break;
10233 default:
323e0a4a 10234 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10235 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10236 break;
10237 }
10238 }
10239
10240 switch (TYPE_CODE (type))
10241 {
10242 case TYPE_CODE_FUNC:
10243 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972
PH
10244 {
10245 struct type *rtype = TYPE_TARGET_TYPE (type);
10246
10247 if (TYPE_GNU_IFUNC (type))
10248 return allocate_value (TYPE_TARGET_TYPE (rtype));
10249 return allocate_value (rtype);
10250 }
4c4b4cd2 10251 return call_function_by_hand (argvec[0], nargs, argvec + 1);
c8ea1972
PH
10252 case TYPE_CODE_INTERNAL_FUNCTION:
10253 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10254 /* We don't know anything about what the internal
10255 function might return, but we have to return
10256 something. */
10257 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10258 not_lval);
10259 else
10260 return call_internal_function (exp->gdbarch, exp->language_defn,
10261 argvec[0], nargs, argvec + 1);
10262
4c4b4cd2
PH
10263 case TYPE_CODE_STRUCT:
10264 {
10265 int arity;
10266
4c4b4cd2
PH
10267 arity = ada_array_arity (type);
10268 type = ada_array_element_type (type, nargs);
10269 if (type == NULL)
323e0a4a 10270 error (_("cannot subscript or call a record"));
4c4b4cd2 10271 if (arity != nargs)
323e0a4a 10272 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10273 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10274 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10275 return
10276 unwrap_value (ada_value_subscript
10277 (argvec[0], nargs, argvec + 1));
10278 }
10279 case TYPE_CODE_ARRAY:
10280 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10281 {
10282 type = ada_array_element_type (type, nargs);
10283 if (type == NULL)
323e0a4a 10284 error (_("element type of array unknown"));
4c4b4cd2 10285 else
0a07e705 10286 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10287 }
10288 return
10289 unwrap_value (ada_value_subscript
10290 (ada_coerce_to_simple_array (argvec[0]),
10291 nargs, argvec + 1));
10292 case TYPE_CODE_PTR: /* Pointer to array */
10293 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10294 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10295 {
10296 type = ada_array_element_type (type, nargs);
10297 if (type == NULL)
323e0a4a 10298 error (_("element type of array unknown"));
4c4b4cd2 10299 else
0a07e705 10300 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10301 }
10302 return
10303 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
10304 nargs, argvec + 1));
10305
10306 default:
e1d5a0d2
PH
10307 error (_("Attempt to index or call something other than an "
10308 "array or function"));
4c4b4cd2
PH
10309 }
10310
10311 case TERNOP_SLICE:
10312 {
10313 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10314 struct value *low_bound_val =
10315 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
10316 struct value *high_bound_val =
10317 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10318 LONGEST low_bound;
10319 LONGEST high_bound;
5b4ee69b 10320
994b9211
AC
10321 low_bound_val = coerce_ref (low_bound_val);
10322 high_bound_val = coerce_ref (high_bound_val);
714e53ab
PH
10323 low_bound = pos_atr (low_bound_val);
10324 high_bound = pos_atr (high_bound_val);
963a6417 10325
4c4b4cd2
PH
10326 if (noside == EVAL_SKIP)
10327 goto nosideret;
10328
4c4b4cd2
PH
10329 /* If this is a reference to an aligner type, then remove all
10330 the aligners. */
df407dfe
AC
10331 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10332 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10333 TYPE_TARGET_TYPE (value_type (array)) =
10334 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 10335
ad82864c 10336 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 10337 error (_("cannot slice a packed array"));
4c4b4cd2
PH
10338
10339 /* If this is a reference to an array or an array lvalue,
10340 convert to a pointer. */
df407dfe
AC
10341 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10342 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
10343 && VALUE_LVAL (array) == lval_memory))
10344 array = value_addr (array);
10345
1265e4aa 10346 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 10347 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 10348 (value_type (array))))
0b5d8877 10349 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
10350
10351 array = ada_coerce_to_simple_array_ptr (array);
10352
714e53ab
PH
10353 /* If we have more than one level of pointer indirection,
10354 dereference the value until we get only one level. */
df407dfe
AC
10355 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10356 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
10357 == TYPE_CODE_PTR))
10358 array = value_ind (array);
10359
10360 /* Make sure we really do have an array type before going further,
10361 to avoid a SEGV when trying to get the index type or the target
10362 type later down the road if the debug info generated by
10363 the compiler is incorrect or incomplete. */
df407dfe 10364 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 10365 error (_("cannot take slice of non-array"));
714e53ab 10366
828292f2
JB
10367 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10368 == TYPE_CODE_PTR)
4c4b4cd2 10369 {
828292f2
JB
10370 struct type *type0 = ada_check_typedef (value_type (array));
10371
0b5d8877 10372 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 10373 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
10374 else
10375 {
10376 struct type *arr_type0 =
828292f2 10377 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 10378
f5938064
JG
10379 return ada_value_slice_from_ptr (array, arr_type0,
10380 longest_to_int (low_bound),
10381 longest_to_int (high_bound));
4c4b4cd2
PH
10382 }
10383 }
10384 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10385 return array;
10386 else if (high_bound < low_bound)
df407dfe 10387 return empty_array (value_type (array), low_bound);
4c4b4cd2 10388 else
529cad9c
PH
10389 return ada_value_slice (array, longest_to_int (low_bound),
10390 longest_to_int (high_bound));
4c4b4cd2 10391 }
14f9c5c9 10392
4c4b4cd2
PH
10393 case UNOP_IN_RANGE:
10394 (*pos) += 2;
10395 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 10396 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 10397
14f9c5c9 10398 if (noside == EVAL_SKIP)
4c4b4cd2 10399 goto nosideret;
14f9c5c9 10400
4c4b4cd2
PH
10401 switch (TYPE_CODE (type))
10402 {
10403 default:
e1d5a0d2
PH
10404 lim_warning (_("Membership test incompletely implemented; "
10405 "always returns true"));
fbb06eb1
UW
10406 type = language_bool_type (exp->language_defn, exp->gdbarch);
10407 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
10408
10409 case TYPE_CODE_RANGE:
030b4912
UW
10410 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10411 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
10412 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10413 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
10414 type = language_bool_type (exp->language_defn, exp->gdbarch);
10415 return
10416 value_from_longest (type,
4c4b4cd2
PH
10417 (value_less (arg1, arg3)
10418 || value_equal (arg1, arg3))
10419 && (value_less (arg2, arg1)
10420 || value_equal (arg2, arg1)));
10421 }
10422
10423 case BINOP_IN_BOUNDS:
14f9c5c9 10424 (*pos) += 2;
4c4b4cd2
PH
10425 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10426 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10427
4c4b4cd2
PH
10428 if (noside == EVAL_SKIP)
10429 goto nosideret;
14f9c5c9 10430
4c4b4cd2 10431 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
10432 {
10433 type = language_bool_type (exp->language_defn, exp->gdbarch);
10434 return value_zero (type, not_lval);
10435 }
14f9c5c9 10436
4c4b4cd2 10437 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 10438
1eea4ebd
UW
10439 type = ada_index_type (value_type (arg2), tem, "range");
10440 if (!type)
10441 type = value_type (arg1);
14f9c5c9 10442
1eea4ebd
UW
10443 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10444 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 10445
f44316fa
UW
10446 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10447 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10448 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10449 return
fbb06eb1 10450 value_from_longest (type,
4c4b4cd2
PH
10451 (value_less (arg1, arg3)
10452 || value_equal (arg1, arg3))
10453 && (value_less (arg2, arg1)
10454 || value_equal (arg2, arg1)));
10455
10456 case TERNOP_IN_RANGE:
10457 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10458 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10459 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10460
10461 if (noside == EVAL_SKIP)
10462 goto nosideret;
10463
f44316fa
UW
10464 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10465 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10466 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10467 return
fbb06eb1 10468 value_from_longest (type,
4c4b4cd2
PH
10469 (value_less (arg1, arg3)
10470 || value_equal (arg1, arg3))
10471 && (value_less (arg2, arg1)
10472 || value_equal (arg2, arg1)));
10473
10474 case OP_ATR_FIRST:
10475 case OP_ATR_LAST:
10476 case OP_ATR_LENGTH:
10477 {
76a01679 10478 struct type *type_arg;
5b4ee69b 10479
76a01679
JB
10480 if (exp->elts[*pos].opcode == OP_TYPE)
10481 {
10482 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10483 arg1 = NULL;
5bc23cb3 10484 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
10485 }
10486 else
10487 {
10488 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10489 type_arg = NULL;
10490 }
10491
10492 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 10493 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
10494 tem = longest_to_int (exp->elts[*pos + 2].longconst);
10495 *pos += 4;
10496
10497 if (noside == EVAL_SKIP)
10498 goto nosideret;
10499
10500 if (type_arg == NULL)
10501 {
10502 arg1 = ada_coerce_ref (arg1);
10503
ad82864c 10504 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
10505 arg1 = ada_coerce_to_simple_array (arg1);
10506
aa4fb036 10507 if (op == OP_ATR_LENGTH)
1eea4ebd 10508 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
10509 else
10510 {
10511 type = ada_index_type (value_type (arg1), tem,
10512 ada_attribute_name (op));
10513 if (type == NULL)
10514 type = builtin_type (exp->gdbarch)->builtin_int;
10515 }
76a01679
JB
10516
10517 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 10518 return allocate_value (type);
76a01679
JB
10519
10520 switch (op)
10521 {
10522 default: /* Should never happen. */
323e0a4a 10523 error (_("unexpected attribute encountered"));
76a01679 10524 case OP_ATR_FIRST:
1eea4ebd
UW
10525 return value_from_longest
10526 (type, ada_array_bound (arg1, tem, 0));
76a01679 10527 case OP_ATR_LAST:
1eea4ebd
UW
10528 return value_from_longest
10529 (type, ada_array_bound (arg1, tem, 1));
76a01679 10530 case OP_ATR_LENGTH:
1eea4ebd
UW
10531 return value_from_longest
10532 (type, ada_array_length (arg1, tem));
76a01679
JB
10533 }
10534 }
10535 else if (discrete_type_p (type_arg))
10536 {
10537 struct type *range_type;
0d5cff50 10538 const char *name = ada_type_name (type_arg);
5b4ee69b 10539
76a01679
JB
10540 range_type = NULL;
10541 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 10542 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
10543 if (range_type == NULL)
10544 range_type = type_arg;
10545 switch (op)
10546 {
10547 default:
323e0a4a 10548 error (_("unexpected attribute encountered"));
76a01679 10549 case OP_ATR_FIRST:
690cc4eb 10550 return value_from_longest
43bbcdc2 10551 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 10552 case OP_ATR_LAST:
690cc4eb 10553 return value_from_longest
43bbcdc2 10554 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 10555 case OP_ATR_LENGTH:
323e0a4a 10556 error (_("the 'length attribute applies only to array types"));
76a01679
JB
10557 }
10558 }
10559 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 10560 error (_("unimplemented type attribute"));
76a01679
JB
10561 else
10562 {
10563 LONGEST low, high;
10564
ad82864c
JB
10565 if (ada_is_constrained_packed_array_type (type_arg))
10566 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 10567
aa4fb036 10568 if (op == OP_ATR_LENGTH)
1eea4ebd 10569 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
10570 else
10571 {
10572 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10573 if (type == NULL)
10574 type = builtin_type (exp->gdbarch)->builtin_int;
10575 }
1eea4ebd 10576
76a01679
JB
10577 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10578 return allocate_value (type);
10579
10580 switch (op)
10581 {
10582 default:
323e0a4a 10583 error (_("unexpected attribute encountered"));
76a01679 10584 case OP_ATR_FIRST:
1eea4ebd 10585 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
10586 return value_from_longest (type, low);
10587 case OP_ATR_LAST:
1eea4ebd 10588 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10589 return value_from_longest (type, high);
10590 case OP_ATR_LENGTH:
1eea4ebd
UW
10591 low = ada_array_bound_from_type (type_arg, tem, 0);
10592 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10593 return value_from_longest (type, high - low + 1);
10594 }
10595 }
14f9c5c9
AS
10596 }
10597
4c4b4cd2
PH
10598 case OP_ATR_TAG:
10599 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10600 if (noside == EVAL_SKIP)
76a01679 10601 goto nosideret;
4c4b4cd2
PH
10602
10603 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10604 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
10605
10606 return ada_value_tag (arg1);
10607
10608 case OP_ATR_MIN:
10609 case OP_ATR_MAX:
10610 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10611 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10612 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10613 if (noside == EVAL_SKIP)
76a01679 10614 goto nosideret;
d2e4a39e 10615 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10616 return value_zero (value_type (arg1), not_lval);
14f9c5c9 10617 else
f44316fa
UW
10618 {
10619 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10620 return value_binop (arg1, arg2,
10621 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
10622 }
14f9c5c9 10623
4c4b4cd2
PH
10624 case OP_ATR_MODULUS:
10625 {
31dedfee 10626 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 10627
5b4ee69b 10628 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
10629 if (noside == EVAL_SKIP)
10630 goto nosideret;
4c4b4cd2 10631
76a01679 10632 if (!ada_is_modular_type (type_arg))
323e0a4a 10633 error (_("'modulus must be applied to modular type"));
4c4b4cd2 10634
76a01679
JB
10635 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
10636 ada_modulus (type_arg));
4c4b4cd2
PH
10637 }
10638
10639
10640 case OP_ATR_POS:
10641 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10642 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10643 if (noside == EVAL_SKIP)
76a01679 10644 goto nosideret;
3cb382c9
UW
10645 type = builtin_type (exp->gdbarch)->builtin_int;
10646 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10647 return value_zero (type, not_lval);
14f9c5c9 10648 else
3cb382c9 10649 return value_pos_atr (type, arg1);
14f9c5c9 10650
4c4b4cd2
PH
10651 case OP_ATR_SIZE:
10652 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
10653 type = value_type (arg1);
10654
10655 /* If the argument is a reference, then dereference its type, since
10656 the user is really asking for the size of the actual object,
10657 not the size of the pointer. */
10658 if (TYPE_CODE (type) == TYPE_CODE_REF)
10659 type = TYPE_TARGET_TYPE (type);
10660
4c4b4cd2 10661 if (noside == EVAL_SKIP)
76a01679 10662 goto nosideret;
4c4b4cd2 10663 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 10664 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 10665 else
22601c15 10666 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 10667 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
10668
10669 case OP_ATR_VAL:
10670 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 10671 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 10672 type = exp->elts[pc + 2].type;
14f9c5c9 10673 if (noside == EVAL_SKIP)
76a01679 10674 goto nosideret;
4c4b4cd2 10675 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10676 return value_zero (type, not_lval);
4c4b4cd2 10677 else
76a01679 10678 return value_val_atr (type, arg1);
4c4b4cd2
PH
10679
10680 case BINOP_EXP:
10681 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10682 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10683 if (noside == EVAL_SKIP)
10684 goto nosideret;
10685 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10686 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 10687 else
f44316fa
UW
10688 {
10689 /* For integer exponentiation operations,
10690 only promote the first argument. */
10691 if (is_integral_type (value_type (arg2)))
10692 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10693 else
10694 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10695
10696 return value_binop (arg1, arg2, op);
10697 }
4c4b4cd2
PH
10698
10699 case UNOP_PLUS:
10700 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10701 if (noside == EVAL_SKIP)
10702 goto nosideret;
10703 else
10704 return arg1;
10705
10706 case UNOP_ABS:
10707 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10708 if (noside == EVAL_SKIP)
10709 goto nosideret;
f44316fa 10710 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 10711 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 10712 return value_neg (arg1);
14f9c5c9 10713 else
4c4b4cd2 10714 return arg1;
14f9c5c9
AS
10715
10716 case UNOP_IND:
5ec18f2b 10717 preeval_pos = *pos;
6b0d7253 10718 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10719 if (noside == EVAL_SKIP)
4c4b4cd2 10720 goto nosideret;
df407dfe 10721 type = ada_check_typedef (value_type (arg1));
14f9c5c9 10722 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
10723 {
10724 if (ada_is_array_descriptor_type (type))
10725 /* GDB allows dereferencing GNAT array descriptors. */
10726 {
10727 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 10728
4c4b4cd2 10729 if (arrType == NULL)
323e0a4a 10730 error (_("Attempt to dereference null array pointer."));
00a4c844 10731 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
10732 }
10733 else if (TYPE_CODE (type) == TYPE_CODE_PTR
10734 || TYPE_CODE (type) == TYPE_CODE_REF
10735 /* In C you can dereference an array to get the 1st elt. */
10736 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab 10737 {
5ec18f2b
JG
10738 /* As mentioned in the OP_VAR_VALUE case, tagged types can
10739 only be determined by inspecting the object's tag.
10740 This means that we need to evaluate completely the
10741 expression in order to get its type. */
10742
10743 if ((TYPE_CODE(type) == TYPE_CODE_REF
10744 || TYPE_CODE(type) == TYPE_CODE_PTR)
10745 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
10746 {
10747 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
10748 EVAL_NORMAL);
10749 type = value_type (ada_value_ind (arg1));
10750 }
10751 else
10752 {
10753 type = to_static_fixed_type
10754 (ada_aligned_type
10755 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10756 }
10757 check_size (type);
714e53ab
PH
10758 return value_zero (type, lval_memory);
10759 }
4c4b4cd2 10760 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
10761 {
10762 /* GDB allows dereferencing an int. */
10763 if (expect_type == NULL)
10764 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10765 lval_memory);
10766 else
10767 {
10768 expect_type =
10769 to_static_fixed_type (ada_aligned_type (expect_type));
10770 return value_zero (expect_type, lval_memory);
10771 }
10772 }
4c4b4cd2 10773 else
323e0a4a 10774 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 10775 }
0963b4bd 10776 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 10777 type = ada_check_typedef (value_type (arg1));
d2e4a39e 10778
96967637
JB
10779 if (TYPE_CODE (type) == TYPE_CODE_INT)
10780 /* GDB allows dereferencing an int. If we were given
10781 the expect_type, then use that as the target type.
10782 Otherwise, assume that the target type is an int. */
10783 {
10784 if (expect_type != NULL)
10785 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10786 arg1));
10787 else
10788 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10789 (CORE_ADDR) value_as_address (arg1));
10790 }
6b0d7253 10791
4c4b4cd2
PH
10792 if (ada_is_array_descriptor_type (type))
10793 /* GDB allows dereferencing GNAT array descriptors. */
10794 return ada_coerce_to_simple_array (arg1);
14f9c5c9 10795 else
4c4b4cd2 10796 return ada_value_ind (arg1);
14f9c5c9
AS
10797
10798 case STRUCTOP_STRUCT:
10799 tem = longest_to_int (exp->elts[pc + 1].longconst);
10800 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
5ec18f2b 10801 preeval_pos = *pos;
14f9c5c9
AS
10802 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10803 if (noside == EVAL_SKIP)
4c4b4cd2 10804 goto nosideret;
14f9c5c9 10805 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10806 {
df407dfe 10807 struct type *type1 = value_type (arg1);
5b4ee69b 10808
76a01679
JB
10809 if (ada_is_tagged_type (type1, 1))
10810 {
10811 type = ada_lookup_struct_elt_type (type1,
10812 &exp->elts[pc + 2].string,
10813 1, 1, NULL);
5ec18f2b
JG
10814
10815 /* If the field is not found, check if it exists in the
10816 extension of this object's type. This means that we
10817 need to evaluate completely the expression. */
10818
76a01679 10819 if (type == NULL)
5ec18f2b
JG
10820 {
10821 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
10822 EVAL_NORMAL);
10823 arg1 = ada_value_struct_elt (arg1,
10824 &exp->elts[pc + 2].string,
10825 0);
10826 arg1 = unwrap_value (arg1);
10827 type = value_type (ada_to_fixed_value (arg1));
10828 }
76a01679
JB
10829 }
10830 else
10831 type =
10832 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
10833 0, NULL);
10834
10835 return value_zero (ada_aligned_type (type), lval_memory);
10836 }
14f9c5c9 10837 else
284614f0
JB
10838 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
10839 arg1 = unwrap_value (arg1);
10840 return ada_to_fixed_value (arg1);
10841
14f9c5c9 10842 case OP_TYPE:
4c4b4cd2
PH
10843 /* The value is not supposed to be used. This is here to make it
10844 easier to accommodate expressions that contain types. */
14f9c5c9
AS
10845 (*pos) += 2;
10846 if (noside == EVAL_SKIP)
4c4b4cd2 10847 goto nosideret;
14f9c5c9 10848 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 10849 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 10850 else
323e0a4a 10851 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
10852
10853 case OP_AGGREGATE:
10854 case OP_CHOICES:
10855 case OP_OTHERS:
10856 case OP_DISCRETE_RANGE:
10857 case OP_POSITIONAL:
10858 case OP_NAME:
10859 if (noside == EVAL_NORMAL)
10860 switch (op)
10861 {
10862 case OP_NAME:
10863 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 10864 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
10865 case OP_AGGREGATE:
10866 error (_("Aggregates only allowed on the right of an assignment"));
10867 default:
0963b4bd
MS
10868 internal_error (__FILE__, __LINE__,
10869 _("aggregate apparently mangled"));
52ce6436
PH
10870 }
10871
10872 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10873 *pos += oplen - 1;
10874 for (tem = 0; tem < nargs; tem += 1)
10875 ada_evaluate_subexp (NULL, exp, pos, noside);
10876 goto nosideret;
14f9c5c9
AS
10877 }
10878
10879nosideret:
22601c15 10880 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
14f9c5c9 10881}
14f9c5c9 10882\f
d2e4a39e 10883
4c4b4cd2 10884 /* Fixed point */
14f9c5c9
AS
10885
10886/* If TYPE encodes an Ada fixed-point type, return the suffix of the
10887 type name that encodes the 'small and 'delta information.
4c4b4cd2 10888 Otherwise, return NULL. */
14f9c5c9 10889
d2e4a39e 10890static const char *
ebf56fd3 10891fixed_type_info (struct type *type)
14f9c5c9 10892{
d2e4a39e 10893 const char *name = ada_type_name (type);
14f9c5c9
AS
10894 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
10895
d2e4a39e
AS
10896 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
10897 {
14f9c5c9 10898 const char *tail = strstr (name, "___XF_");
5b4ee69b 10899
14f9c5c9 10900 if (tail == NULL)
4c4b4cd2 10901 return NULL;
d2e4a39e 10902 else
4c4b4cd2 10903 return tail + 5;
14f9c5c9
AS
10904 }
10905 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
10906 return fixed_type_info (TYPE_TARGET_TYPE (type));
10907 else
10908 return NULL;
10909}
10910
4c4b4cd2 10911/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
10912
10913int
ebf56fd3 10914ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
10915{
10916 return fixed_type_info (type) != NULL;
10917}
10918
4c4b4cd2
PH
10919/* Return non-zero iff TYPE represents a System.Address type. */
10920
10921int
10922ada_is_system_address_type (struct type *type)
10923{
10924 return (TYPE_NAME (type)
10925 && strcmp (TYPE_NAME (type), "system__address") == 0);
10926}
10927
14f9c5c9
AS
10928/* Assuming that TYPE is the representation of an Ada fixed-point
10929 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 10930 delta cannot be determined. */
14f9c5c9
AS
10931
10932DOUBLEST
ebf56fd3 10933ada_delta (struct type *type)
14f9c5c9
AS
10934{
10935 const char *encoding = fixed_type_info (type);
facc390f 10936 DOUBLEST num, den;
14f9c5c9 10937
facc390f
JB
10938 /* Strictly speaking, num and den are encoded as integer. However,
10939 they may not fit into a long, and they will have to be converted
10940 to DOUBLEST anyway. So scan them as DOUBLEST. */
10941 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10942 &num, &den) < 2)
14f9c5c9 10943 return -1.0;
d2e4a39e 10944 else
facc390f 10945 return num / den;
14f9c5c9
AS
10946}
10947
10948/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 10949 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
10950
10951static DOUBLEST
ebf56fd3 10952scaling_factor (struct type *type)
14f9c5c9
AS
10953{
10954 const char *encoding = fixed_type_info (type);
facc390f 10955 DOUBLEST num0, den0, num1, den1;
14f9c5c9 10956 int n;
d2e4a39e 10957
facc390f
JB
10958 /* Strictly speaking, num's and den's are encoded as integer. However,
10959 they may not fit into a long, and they will have to be converted
10960 to DOUBLEST anyway. So scan them as DOUBLEST. */
10961 n = sscanf (encoding,
10962 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
10963 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10964 &num0, &den0, &num1, &den1);
14f9c5c9
AS
10965
10966 if (n < 2)
10967 return 1.0;
10968 else if (n == 4)
facc390f 10969 return num1 / den1;
d2e4a39e 10970 else
facc390f 10971 return num0 / den0;
14f9c5c9
AS
10972}
10973
10974
10975/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 10976 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
10977
10978DOUBLEST
ebf56fd3 10979ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 10980{
d2e4a39e 10981 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
10982}
10983
4c4b4cd2
PH
10984/* The representation of a fixed-point value of type TYPE
10985 corresponding to the value X. */
14f9c5c9
AS
10986
10987LONGEST
ebf56fd3 10988ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
10989{
10990 return (LONGEST) (x / scaling_factor (type) + 0.5);
10991}
10992
14f9c5c9 10993\f
d2e4a39e 10994
4c4b4cd2 10995 /* Range types */
14f9c5c9
AS
10996
10997/* Scan STR beginning at position K for a discriminant name, and
10998 return the value of that discriminant field of DVAL in *PX. If
10999 PNEW_K is not null, put the position of the character beyond the
11000 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 11001 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
11002
11003static int
07d8f827 11004scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
76a01679 11005 int *pnew_k)
14f9c5c9
AS
11006{
11007 static char *bound_buffer = NULL;
11008 static size_t bound_buffer_len = 0;
11009 char *bound;
11010 char *pend;
d2e4a39e 11011 struct value *bound_val;
14f9c5c9
AS
11012
11013 if (dval == NULL || str == NULL || str[k] == '\0')
11014 return 0;
11015
d2e4a39e 11016 pend = strstr (str + k, "__");
14f9c5c9
AS
11017 if (pend == NULL)
11018 {
d2e4a39e 11019 bound = str + k;
14f9c5c9
AS
11020 k += strlen (bound);
11021 }
d2e4a39e 11022 else
14f9c5c9 11023 {
d2e4a39e 11024 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
14f9c5c9 11025 bound = bound_buffer;
d2e4a39e
AS
11026 strncpy (bound_buffer, str + k, pend - (str + k));
11027 bound[pend - (str + k)] = '\0';
11028 k = pend - str;
14f9c5c9 11029 }
d2e4a39e 11030
df407dfe 11031 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11032 if (bound_val == NULL)
11033 return 0;
11034
11035 *px = value_as_long (bound_val);
11036 if (pnew_k != NULL)
11037 *pnew_k = k;
11038 return 1;
11039}
11040
11041/* Value of variable named NAME in the current environment. If
11042 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11043 otherwise causes an error with message ERR_MSG. */
11044
d2e4a39e
AS
11045static struct value *
11046get_var_value (char *name, char *err_msg)
14f9c5c9 11047{
4c4b4cd2 11048 struct ada_symbol_info *syms;
14f9c5c9
AS
11049 int nsyms;
11050
4c4b4cd2 11051 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
4eeaa230 11052 &syms);
14f9c5c9
AS
11053
11054 if (nsyms != 1)
11055 {
11056 if (err_msg == NULL)
4c4b4cd2 11057 return 0;
14f9c5c9 11058 else
8a3fe4f8 11059 error (("%s"), err_msg);
14f9c5c9
AS
11060 }
11061
4c4b4cd2 11062 return value_of_variable (syms[0].sym, syms[0].block);
14f9c5c9 11063}
d2e4a39e 11064
14f9c5c9 11065/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
11066 no such variable found, returns 0, and sets *FLAG to 0. If
11067 successful, sets *FLAG to 1. */
11068
14f9c5c9 11069LONGEST
4c4b4cd2 11070get_int_var_value (char *name, int *flag)
14f9c5c9 11071{
4c4b4cd2 11072 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11073
14f9c5c9
AS
11074 if (var_val == 0)
11075 {
11076 if (flag != NULL)
4c4b4cd2 11077 *flag = 0;
14f9c5c9
AS
11078 return 0;
11079 }
11080 else
11081 {
11082 if (flag != NULL)
4c4b4cd2 11083 *flag = 1;
14f9c5c9
AS
11084 return value_as_long (var_val);
11085 }
11086}
d2e4a39e 11087
14f9c5c9
AS
11088
11089/* Return a range type whose base type is that of the range type named
11090 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11091 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11092 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11093 corresponding range type from debug information; fall back to using it
11094 if symbol lookup fails. If a new type must be created, allocate it
11095 like ORIG_TYPE was. The bounds information, in general, is encoded
11096 in NAME, the base type given in the named range type. */
14f9c5c9 11097
d2e4a39e 11098static struct type *
28c85d6c 11099to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11100{
0d5cff50 11101 const char *name;
14f9c5c9 11102 struct type *base_type;
d2e4a39e 11103 char *subtype_info;
14f9c5c9 11104
28c85d6c
JB
11105 gdb_assert (raw_type != NULL);
11106 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11107
1ce677a4 11108 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11109 base_type = TYPE_TARGET_TYPE (raw_type);
11110 else
11111 base_type = raw_type;
11112
28c85d6c 11113 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11114 subtype_info = strstr (name, "___XD");
11115 if (subtype_info == NULL)
690cc4eb 11116 {
43bbcdc2
PH
11117 LONGEST L = ada_discrete_type_low_bound (raw_type);
11118 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11119
690cc4eb
PH
11120 if (L < INT_MIN || U > INT_MAX)
11121 return raw_type;
11122 else
28c85d6c 11123 return create_range_type (alloc_type_copy (raw_type), raw_type,
43bbcdc2
PH
11124 ada_discrete_type_low_bound (raw_type),
11125 ada_discrete_type_high_bound (raw_type));
690cc4eb 11126 }
14f9c5c9
AS
11127 else
11128 {
11129 static char *name_buf = NULL;
11130 static size_t name_len = 0;
11131 int prefix_len = subtype_info - name;
11132 LONGEST L, U;
11133 struct type *type;
11134 char *bounds_str;
11135 int n;
11136
11137 GROW_VECT (name_buf, name_len, prefix_len + 5);
11138 strncpy (name_buf, name, prefix_len);
11139 name_buf[prefix_len] = '\0';
11140
11141 subtype_info += 5;
11142 bounds_str = strchr (subtype_info, '_');
11143 n = 1;
11144
d2e4a39e 11145 if (*subtype_info == 'L')
4c4b4cd2
PH
11146 {
11147 if (!ada_scan_number (bounds_str, n, &L, &n)
11148 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11149 return raw_type;
11150 if (bounds_str[n] == '_')
11151 n += 2;
0963b4bd 11152 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11153 n += 1;
11154 subtype_info += 1;
11155 }
d2e4a39e 11156 else
4c4b4cd2
PH
11157 {
11158 int ok;
5b4ee69b 11159
4c4b4cd2
PH
11160 strcpy (name_buf + prefix_len, "___L");
11161 L = get_int_var_value (name_buf, &ok);
11162 if (!ok)
11163 {
323e0a4a 11164 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11165 L = 1;
11166 }
11167 }
14f9c5c9 11168
d2e4a39e 11169 if (*subtype_info == 'U')
4c4b4cd2
PH
11170 {
11171 if (!ada_scan_number (bounds_str, n, &U, &n)
11172 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11173 return raw_type;
11174 }
d2e4a39e 11175 else
4c4b4cd2
PH
11176 {
11177 int ok;
5b4ee69b 11178
4c4b4cd2
PH
11179 strcpy (name_buf + prefix_len, "___U");
11180 U = get_int_var_value (name_buf, &ok);
11181 if (!ok)
11182 {
323e0a4a 11183 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11184 U = L;
11185 }
11186 }
14f9c5c9 11187
28c85d6c 11188 type = create_range_type (alloc_type_copy (raw_type), base_type, L, U);
d2e4a39e 11189 TYPE_NAME (type) = name;
14f9c5c9
AS
11190 return type;
11191 }
11192}
11193
4c4b4cd2
PH
11194/* True iff NAME is the name of a range type. */
11195
14f9c5c9 11196int
d2e4a39e 11197ada_is_range_type_name (const char *name)
14f9c5c9
AS
11198{
11199 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11200}
14f9c5c9 11201\f
d2e4a39e 11202
4c4b4cd2
PH
11203 /* Modular types */
11204
11205/* True iff TYPE is an Ada modular type. */
14f9c5c9 11206
14f9c5c9 11207int
d2e4a39e 11208ada_is_modular_type (struct type *type)
14f9c5c9 11209{
18af8284 11210 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11211
11212 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11213 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11214 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11215}
11216
4c4b4cd2
PH
11217/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11218
61ee279c 11219ULONGEST
0056e4d5 11220ada_modulus (struct type *type)
14f9c5c9 11221{
43bbcdc2 11222 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11223}
d2e4a39e 11224\f
f7f9143b
JB
11225
11226/* Ada exception catchpoint support:
11227 ---------------------------------
11228
11229 We support 3 kinds of exception catchpoints:
11230 . catchpoints on Ada exceptions
11231 . catchpoints on unhandled Ada exceptions
11232 . catchpoints on failed assertions
11233
11234 Exceptions raised during failed assertions, or unhandled exceptions
11235 could perfectly be caught with the general catchpoint on Ada exceptions.
11236 However, we can easily differentiate these two special cases, and having
11237 the option to distinguish these two cases from the rest can be useful
11238 to zero-in on certain situations.
11239
11240 Exception catchpoints are a specialized form of breakpoint,
11241 since they rely on inserting breakpoints inside known routines
11242 of the GNAT runtime. The implementation therefore uses a standard
11243 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11244 of breakpoint_ops.
11245
0259addd
JB
11246 Support in the runtime for exception catchpoints have been changed
11247 a few times already, and these changes affect the implementation
11248 of these catchpoints. In order to be able to support several
11249 variants of the runtime, we use a sniffer that will determine
28010a5d 11250 the runtime variant used by the program being debugged. */
f7f9143b 11251
3d0b0fa3
JB
11252/* Ada's standard exceptions. */
11253
11254static char *standard_exc[] = {
11255 "constraint_error",
11256 "program_error",
11257 "storage_error",
11258 "tasking_error"
11259};
11260
0259addd
JB
11261typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11262
11263/* A structure that describes how to support exception catchpoints
11264 for a given executable. */
11265
11266struct exception_support_info
11267{
11268 /* The name of the symbol to break on in order to insert
11269 a catchpoint on exceptions. */
11270 const char *catch_exception_sym;
11271
11272 /* The name of the symbol to break on in order to insert
11273 a catchpoint on unhandled exceptions. */
11274 const char *catch_exception_unhandled_sym;
11275
11276 /* The name of the symbol to break on in order to insert
11277 a catchpoint on failed assertions. */
11278 const char *catch_assert_sym;
11279
11280 /* Assuming that the inferior just triggered an unhandled exception
11281 catchpoint, this function is responsible for returning the address
11282 in inferior memory where the name of that exception is stored.
11283 Return zero if the address could not be computed. */
11284 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11285};
11286
11287static CORE_ADDR ada_unhandled_exception_name_addr (void);
11288static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11289
11290/* The following exception support info structure describes how to
11291 implement exception catchpoints with the latest version of the
11292 Ada runtime (as of 2007-03-06). */
11293
11294static const struct exception_support_info default_exception_support_info =
11295{
11296 "__gnat_debug_raise_exception", /* catch_exception_sym */
11297 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11298 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11299 ada_unhandled_exception_name_addr
11300};
11301
11302/* The following exception support info structure describes how to
11303 implement exception catchpoints with a slightly older version
11304 of the Ada runtime. */
11305
11306static const struct exception_support_info exception_support_info_fallback =
11307{
11308 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11309 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11310 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11311 ada_unhandled_exception_name_addr_from_raise
11312};
11313
f17011e0
JB
11314/* Return nonzero if we can detect the exception support routines
11315 described in EINFO.
11316
11317 This function errors out if an abnormal situation is detected
11318 (for instance, if we find the exception support routines, but
11319 that support is found to be incomplete). */
11320
11321static int
11322ada_has_this_exception_support (const struct exception_support_info *einfo)
11323{
11324 struct symbol *sym;
11325
11326 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11327 that should be compiled with debugging information. As a result, we
11328 expect to find that symbol in the symtabs. */
11329
11330 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11331 if (sym == NULL)
a6af7abe
JB
11332 {
11333 /* Perhaps we did not find our symbol because the Ada runtime was
11334 compiled without debugging info, or simply stripped of it.
11335 It happens on some GNU/Linux distributions for instance, where
11336 users have to install a separate debug package in order to get
11337 the runtime's debugging info. In that situation, let the user
11338 know why we cannot insert an Ada exception catchpoint.
11339
11340 Note: Just for the purpose of inserting our Ada exception
11341 catchpoint, we could rely purely on the associated minimal symbol.
11342 But we would be operating in degraded mode anyway, since we are
11343 still lacking the debugging info needed later on to extract
11344 the name of the exception being raised (this name is printed in
11345 the catchpoint message, and is also used when trying to catch
11346 a specific exception). We do not handle this case for now. */
3b7344d5 11347 struct bound_minimal_symbol msym
1c8e84b0
JB
11348 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11349
3b7344d5 11350 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
11351 error (_("Your Ada runtime appears to be missing some debugging "
11352 "information.\nCannot insert Ada exception catchpoint "
11353 "in this configuration."));
11354
11355 return 0;
11356 }
f17011e0
JB
11357
11358 /* Make sure that the symbol we found corresponds to a function. */
11359
11360 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11361 error (_("Symbol \"%s\" is not a function (class = %d)"),
11362 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11363
11364 return 1;
11365}
11366
0259addd
JB
11367/* Inspect the Ada runtime and determine which exception info structure
11368 should be used to provide support for exception catchpoints.
11369
3eecfa55
JB
11370 This function will always set the per-inferior exception_info,
11371 or raise an error. */
0259addd
JB
11372
11373static void
11374ada_exception_support_info_sniffer (void)
11375{
3eecfa55 11376 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
11377
11378 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 11379 if (data->exception_info != NULL)
0259addd
JB
11380 return;
11381
11382 /* Check the latest (default) exception support info. */
f17011e0 11383 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 11384 {
3eecfa55 11385 data->exception_info = &default_exception_support_info;
0259addd
JB
11386 return;
11387 }
11388
11389 /* Try our fallback exception suport info. */
f17011e0 11390 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 11391 {
3eecfa55 11392 data->exception_info = &exception_support_info_fallback;
0259addd
JB
11393 return;
11394 }
11395
11396 /* Sometimes, it is normal for us to not be able to find the routine
11397 we are looking for. This happens when the program is linked with
11398 the shared version of the GNAT runtime, and the program has not been
11399 started yet. Inform the user of these two possible causes if
11400 applicable. */
11401
ccefe4c4 11402 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
11403 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11404
11405 /* If the symbol does not exist, then check that the program is
11406 already started, to make sure that shared libraries have been
11407 loaded. If it is not started, this may mean that the symbol is
11408 in a shared library. */
11409
11410 if (ptid_get_pid (inferior_ptid) == 0)
11411 error (_("Unable to insert catchpoint. Try to start the program first."));
11412
11413 /* At this point, we know that we are debugging an Ada program and
11414 that the inferior has been started, but we still are not able to
0963b4bd 11415 find the run-time symbols. That can mean that we are in
0259addd
JB
11416 configurable run time mode, or that a-except as been optimized
11417 out by the linker... In any case, at this point it is not worth
11418 supporting this feature. */
11419
7dda8cff 11420 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
11421}
11422
f7f9143b
JB
11423/* True iff FRAME is very likely to be that of a function that is
11424 part of the runtime system. This is all very heuristic, but is
11425 intended to be used as advice as to what frames are uninteresting
11426 to most users. */
11427
11428static int
11429is_known_support_routine (struct frame_info *frame)
11430{
4ed6b5be 11431 struct symtab_and_line sal;
55b87a52 11432 char *func_name;
692465f1 11433 enum language func_lang;
f7f9143b 11434 int i;
f35a17b5 11435 const char *fullname;
f7f9143b 11436
4ed6b5be
JB
11437 /* If this code does not have any debugging information (no symtab),
11438 This cannot be any user code. */
f7f9143b 11439
4ed6b5be 11440 find_frame_sal (frame, &sal);
f7f9143b
JB
11441 if (sal.symtab == NULL)
11442 return 1;
11443
4ed6b5be
JB
11444 /* If there is a symtab, but the associated source file cannot be
11445 located, then assume this is not user code: Selecting a frame
11446 for which we cannot display the code would not be very helpful
11447 for the user. This should also take care of case such as VxWorks
11448 where the kernel has some debugging info provided for a few units. */
f7f9143b 11449
f35a17b5
JK
11450 fullname = symtab_to_fullname (sal.symtab);
11451 if (access (fullname, R_OK) != 0)
f7f9143b
JB
11452 return 1;
11453
4ed6b5be
JB
11454 /* Check the unit filename againt the Ada runtime file naming.
11455 We also check the name of the objfile against the name of some
11456 known system libraries that sometimes come with debugging info
11457 too. */
11458
f7f9143b
JB
11459 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11460 {
11461 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 11462 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 11463 return 1;
4ed6b5be 11464 if (sal.symtab->objfile != NULL
4262abfb 11465 && re_exec (objfile_name (sal.symtab->objfile)))
4ed6b5be 11466 return 1;
f7f9143b
JB
11467 }
11468
4ed6b5be 11469 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 11470
e9e07ba6 11471 find_frame_funname (frame, &func_name, &func_lang, NULL);
f7f9143b
JB
11472 if (func_name == NULL)
11473 return 1;
11474
11475 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11476 {
11477 re_comp (known_auxiliary_function_name_patterns[i]);
11478 if (re_exec (func_name))
55b87a52
KS
11479 {
11480 xfree (func_name);
11481 return 1;
11482 }
f7f9143b
JB
11483 }
11484
55b87a52 11485 xfree (func_name);
f7f9143b
JB
11486 return 0;
11487}
11488
11489/* Find the first frame that contains debugging information and that is not
11490 part of the Ada run-time, starting from FI and moving upward. */
11491
0ef643c8 11492void
f7f9143b
JB
11493ada_find_printable_frame (struct frame_info *fi)
11494{
11495 for (; fi != NULL; fi = get_prev_frame (fi))
11496 {
11497 if (!is_known_support_routine (fi))
11498 {
11499 select_frame (fi);
11500 break;
11501 }
11502 }
11503
11504}
11505
11506/* Assuming that the inferior just triggered an unhandled exception
11507 catchpoint, return the address in inferior memory where the name
11508 of the exception is stored.
11509
11510 Return zero if the address could not be computed. */
11511
11512static CORE_ADDR
11513ada_unhandled_exception_name_addr (void)
0259addd
JB
11514{
11515 return parse_and_eval_address ("e.full_name");
11516}
11517
11518/* Same as ada_unhandled_exception_name_addr, except that this function
11519 should be used when the inferior uses an older version of the runtime,
11520 where the exception name needs to be extracted from a specific frame
11521 several frames up in the callstack. */
11522
11523static CORE_ADDR
11524ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
11525{
11526 int frame_level;
11527 struct frame_info *fi;
3eecfa55 11528 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
55b87a52 11529 struct cleanup *old_chain;
f7f9143b
JB
11530
11531 /* To determine the name of this exception, we need to select
11532 the frame corresponding to RAISE_SYM_NAME. This frame is
11533 at least 3 levels up, so we simply skip the first 3 frames
11534 without checking the name of their associated function. */
11535 fi = get_current_frame ();
11536 for (frame_level = 0; frame_level < 3; frame_level += 1)
11537 if (fi != NULL)
11538 fi = get_prev_frame (fi);
11539
55b87a52 11540 old_chain = make_cleanup (null_cleanup, NULL);
f7f9143b
JB
11541 while (fi != NULL)
11542 {
55b87a52 11543 char *func_name;
692465f1
JB
11544 enum language func_lang;
11545
e9e07ba6 11546 find_frame_funname (fi, &func_name, &func_lang, NULL);
55b87a52
KS
11547 if (func_name != NULL)
11548 {
11549 make_cleanup (xfree, func_name);
11550
11551 if (strcmp (func_name,
11552 data->exception_info->catch_exception_sym) == 0)
11553 break; /* We found the frame we were looking for... */
11554 fi = get_prev_frame (fi);
11555 }
f7f9143b 11556 }
55b87a52 11557 do_cleanups (old_chain);
f7f9143b
JB
11558
11559 if (fi == NULL)
11560 return 0;
11561
11562 select_frame (fi);
11563 return parse_and_eval_address ("id.full_name");
11564}
11565
11566/* Assuming the inferior just triggered an Ada exception catchpoint
11567 (of any type), return the address in inferior memory where the name
11568 of the exception is stored, if applicable.
11569
11570 Return zero if the address could not be computed, or if not relevant. */
11571
11572static CORE_ADDR
761269c8 11573ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11574 struct breakpoint *b)
11575{
3eecfa55
JB
11576 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11577
f7f9143b
JB
11578 switch (ex)
11579 {
761269c8 11580 case ada_catch_exception:
f7f9143b
JB
11581 return (parse_and_eval_address ("e.full_name"));
11582 break;
11583
761269c8 11584 case ada_catch_exception_unhandled:
3eecfa55 11585 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
11586 break;
11587
761269c8 11588 case ada_catch_assert:
f7f9143b
JB
11589 return 0; /* Exception name is not relevant in this case. */
11590 break;
11591
11592 default:
11593 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11594 break;
11595 }
11596
11597 return 0; /* Should never be reached. */
11598}
11599
11600/* Same as ada_exception_name_addr_1, except that it intercepts and contains
11601 any error that ada_exception_name_addr_1 might cause to be thrown.
11602 When an error is intercepted, a warning with the error message is printed,
11603 and zero is returned. */
11604
11605static CORE_ADDR
761269c8 11606ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11607 struct breakpoint *b)
11608{
bfd189b1 11609 volatile struct gdb_exception e;
f7f9143b
JB
11610 CORE_ADDR result = 0;
11611
11612 TRY_CATCH (e, RETURN_MASK_ERROR)
11613 {
11614 result = ada_exception_name_addr_1 (ex, b);
11615 }
11616
11617 if (e.reason < 0)
11618 {
11619 warning (_("failed to get exception name: %s"), e.message);
11620 return 0;
11621 }
11622
11623 return result;
11624}
11625
28010a5d
PA
11626static char *ada_exception_catchpoint_cond_string (const char *excep_string);
11627
11628/* Ada catchpoints.
11629
11630 In the case of catchpoints on Ada exceptions, the catchpoint will
11631 stop the target on every exception the program throws. When a user
11632 specifies the name of a specific exception, we translate this
11633 request into a condition expression (in text form), and then parse
11634 it into an expression stored in each of the catchpoint's locations.
11635 We then use this condition to check whether the exception that was
11636 raised is the one the user is interested in. If not, then the
11637 target is resumed again. We store the name of the requested
11638 exception, in order to be able to re-set the condition expression
11639 when symbols change. */
11640
11641/* An instance of this type is used to represent an Ada catchpoint
11642 breakpoint location. It includes a "struct bp_location" as a kind
11643 of base class; users downcast to "struct bp_location *" when
11644 needed. */
11645
11646struct ada_catchpoint_location
11647{
11648 /* The base class. */
11649 struct bp_location base;
11650
11651 /* The condition that checks whether the exception that was raised
11652 is the specific exception the user specified on catchpoint
11653 creation. */
11654 struct expression *excep_cond_expr;
11655};
11656
11657/* Implement the DTOR method in the bp_location_ops structure for all
11658 Ada exception catchpoint kinds. */
11659
11660static void
11661ada_catchpoint_location_dtor (struct bp_location *bl)
11662{
11663 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
11664
11665 xfree (al->excep_cond_expr);
11666}
11667
11668/* The vtable to be used in Ada catchpoint locations. */
11669
11670static const struct bp_location_ops ada_catchpoint_location_ops =
11671{
11672 ada_catchpoint_location_dtor
11673};
11674
11675/* An instance of this type is used to represent an Ada catchpoint.
11676 It includes a "struct breakpoint" as a kind of base class; users
11677 downcast to "struct breakpoint *" when needed. */
11678
11679struct ada_catchpoint
11680{
11681 /* The base class. */
11682 struct breakpoint base;
11683
11684 /* The name of the specific exception the user specified. */
11685 char *excep_string;
11686};
11687
11688/* Parse the exception condition string in the context of each of the
11689 catchpoint's locations, and store them for later evaluation. */
11690
11691static void
11692create_excep_cond_exprs (struct ada_catchpoint *c)
11693{
11694 struct cleanup *old_chain;
11695 struct bp_location *bl;
11696 char *cond_string;
11697
11698 /* Nothing to do if there's no specific exception to catch. */
11699 if (c->excep_string == NULL)
11700 return;
11701
11702 /* Same if there are no locations... */
11703 if (c->base.loc == NULL)
11704 return;
11705
11706 /* Compute the condition expression in text form, from the specific
11707 expection we want to catch. */
11708 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
11709 old_chain = make_cleanup (xfree, cond_string);
11710
11711 /* Iterate over all the catchpoint's locations, and parse an
11712 expression for each. */
11713 for (bl = c->base.loc; bl != NULL; bl = bl->next)
11714 {
11715 struct ada_catchpoint_location *ada_loc
11716 = (struct ada_catchpoint_location *) bl;
11717 struct expression *exp = NULL;
11718
11719 if (!bl->shlib_disabled)
11720 {
11721 volatile struct gdb_exception e;
bbc13ae3 11722 const char *s;
28010a5d
PA
11723
11724 s = cond_string;
11725 TRY_CATCH (e, RETURN_MASK_ERROR)
11726 {
1bb9788d
TT
11727 exp = parse_exp_1 (&s, bl->address,
11728 block_for_pc (bl->address), 0);
28010a5d
PA
11729 }
11730 if (e.reason < 0)
849f2b52
JB
11731 {
11732 warning (_("failed to reevaluate internal exception condition "
11733 "for catchpoint %d: %s"),
11734 c->base.number, e.message);
11735 /* There is a bug in GCC on sparc-solaris when building with
11736 optimization which causes EXP to change unexpectedly
11737 (http://gcc.gnu.org/bugzilla/show_bug.cgi?id=56982).
11738 The problem should be fixed starting with GCC 4.9.
11739 In the meantime, work around it by forcing EXP back
11740 to NULL. */
11741 exp = NULL;
11742 }
28010a5d
PA
11743 }
11744
11745 ada_loc->excep_cond_expr = exp;
11746 }
11747
11748 do_cleanups (old_chain);
11749}
11750
11751/* Implement the DTOR method in the breakpoint_ops structure for all
11752 exception catchpoint kinds. */
11753
11754static void
761269c8 11755dtor_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
11756{
11757 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11758
11759 xfree (c->excep_string);
348d480f 11760
2060206e 11761 bkpt_breakpoint_ops.dtor (b);
28010a5d
PA
11762}
11763
11764/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11765 structure for all exception catchpoint kinds. */
11766
11767static struct bp_location *
761269c8 11768allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
11769 struct breakpoint *self)
11770{
11771 struct ada_catchpoint_location *loc;
11772
11773 loc = XNEW (struct ada_catchpoint_location);
11774 init_bp_location (&loc->base, &ada_catchpoint_location_ops, self);
11775 loc->excep_cond_expr = NULL;
11776 return &loc->base;
11777}
11778
11779/* Implement the RE_SET method in the breakpoint_ops structure for all
11780 exception catchpoint kinds. */
11781
11782static void
761269c8 11783re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
11784{
11785 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11786
11787 /* Call the base class's method. This updates the catchpoint's
11788 locations. */
2060206e 11789 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
11790
11791 /* Reparse the exception conditional expressions. One for each
11792 location. */
11793 create_excep_cond_exprs (c);
11794}
11795
11796/* Returns true if we should stop for this breakpoint hit. If the
11797 user specified a specific exception, we only want to cause a stop
11798 if the program thrown that exception. */
11799
11800static int
11801should_stop_exception (const struct bp_location *bl)
11802{
11803 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11804 const struct ada_catchpoint_location *ada_loc
11805 = (const struct ada_catchpoint_location *) bl;
11806 volatile struct gdb_exception ex;
11807 int stop;
11808
11809 /* With no specific exception, should always stop. */
11810 if (c->excep_string == NULL)
11811 return 1;
11812
11813 if (ada_loc->excep_cond_expr == NULL)
11814 {
11815 /* We will have a NULL expression if back when we were creating
11816 the expressions, this location's had failed to parse. */
11817 return 1;
11818 }
11819
11820 stop = 1;
11821 TRY_CATCH (ex, RETURN_MASK_ALL)
11822 {
11823 struct value *mark;
11824
11825 mark = value_mark ();
11826 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr));
11827 value_free_to_mark (mark);
11828 }
11829 if (ex.reason < 0)
11830 exception_fprintf (gdb_stderr, ex,
11831 _("Error in testing exception condition:\n"));
11832 return stop;
11833}
11834
11835/* Implement the CHECK_STATUS method in the breakpoint_ops structure
11836 for all exception catchpoint kinds. */
11837
11838static void
761269c8 11839check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
11840{
11841 bs->stop = should_stop_exception (bs->bp_location_at);
11842}
11843
f7f9143b
JB
11844/* Implement the PRINT_IT method in the breakpoint_ops structure
11845 for all exception catchpoint kinds. */
11846
11847static enum print_stop_action
761269c8 11848print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 11849{
79a45e25 11850 struct ui_out *uiout = current_uiout;
348d480f
PA
11851 struct breakpoint *b = bs->breakpoint_at;
11852
956a9fb9 11853 annotate_catchpoint (b->number);
f7f9143b 11854
956a9fb9 11855 if (ui_out_is_mi_like_p (uiout))
f7f9143b 11856 {
956a9fb9
JB
11857 ui_out_field_string (uiout, "reason",
11858 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11859 ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition));
f7f9143b
JB
11860 }
11861
00eb2c4a
JB
11862 ui_out_text (uiout,
11863 b->disposition == disp_del ? "\nTemporary catchpoint "
11864 : "\nCatchpoint ");
956a9fb9
JB
11865 ui_out_field_int (uiout, "bkptno", b->number);
11866 ui_out_text (uiout, ", ");
f7f9143b 11867
f7f9143b
JB
11868 switch (ex)
11869 {
761269c8
JB
11870 case ada_catch_exception:
11871 case ada_catch_exception_unhandled:
956a9fb9
JB
11872 {
11873 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
11874 char exception_name[256];
11875
11876 if (addr != 0)
11877 {
c714b426
PA
11878 read_memory (addr, (gdb_byte *) exception_name,
11879 sizeof (exception_name) - 1);
956a9fb9
JB
11880 exception_name [sizeof (exception_name) - 1] = '\0';
11881 }
11882 else
11883 {
11884 /* For some reason, we were unable to read the exception
11885 name. This could happen if the Runtime was compiled
11886 without debugging info, for instance. In that case,
11887 just replace the exception name by the generic string
11888 "exception" - it will read as "an exception" in the
11889 notification we are about to print. */
967cff16 11890 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
11891 }
11892 /* In the case of unhandled exception breakpoints, we print
11893 the exception name as "unhandled EXCEPTION_NAME", to make
11894 it clearer to the user which kind of catchpoint just got
11895 hit. We used ui_out_text to make sure that this extra
11896 info does not pollute the exception name in the MI case. */
761269c8 11897 if (ex == ada_catch_exception_unhandled)
956a9fb9
JB
11898 ui_out_text (uiout, "unhandled ");
11899 ui_out_field_string (uiout, "exception-name", exception_name);
11900 }
11901 break;
761269c8 11902 case ada_catch_assert:
956a9fb9
JB
11903 /* In this case, the name of the exception is not really
11904 important. Just print "failed assertion" to make it clearer
11905 that his program just hit an assertion-failure catchpoint.
11906 We used ui_out_text because this info does not belong in
11907 the MI output. */
11908 ui_out_text (uiout, "failed assertion");
11909 break;
f7f9143b 11910 }
956a9fb9
JB
11911 ui_out_text (uiout, " at ");
11912 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
11913
11914 return PRINT_SRC_AND_LOC;
11915}
11916
11917/* Implement the PRINT_ONE method in the breakpoint_ops structure
11918 for all exception catchpoint kinds. */
11919
11920static void
761269c8 11921print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 11922 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11923{
79a45e25 11924 struct ui_out *uiout = current_uiout;
28010a5d 11925 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
11926 struct value_print_options opts;
11927
11928 get_user_print_options (&opts);
11929 if (opts.addressprint)
f7f9143b
JB
11930 {
11931 annotate_field (4);
5af949e3 11932 ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
11933 }
11934
11935 annotate_field (5);
a6d9a66e 11936 *last_loc = b->loc;
f7f9143b
JB
11937 switch (ex)
11938 {
761269c8 11939 case ada_catch_exception:
28010a5d 11940 if (c->excep_string != NULL)
f7f9143b 11941 {
28010a5d
PA
11942 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11943
f7f9143b
JB
11944 ui_out_field_string (uiout, "what", msg);
11945 xfree (msg);
11946 }
11947 else
11948 ui_out_field_string (uiout, "what", "all Ada exceptions");
11949
11950 break;
11951
761269c8 11952 case ada_catch_exception_unhandled:
f7f9143b
JB
11953 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
11954 break;
11955
761269c8 11956 case ada_catch_assert:
f7f9143b
JB
11957 ui_out_field_string (uiout, "what", "failed Ada assertions");
11958 break;
11959
11960 default:
11961 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11962 break;
11963 }
11964}
11965
11966/* Implement the PRINT_MENTION method in the breakpoint_ops structure
11967 for all exception catchpoint kinds. */
11968
11969static void
761269c8 11970print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11971 struct breakpoint *b)
11972{
28010a5d 11973 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 11974 struct ui_out *uiout = current_uiout;
28010a5d 11975
00eb2c4a
JB
11976 ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ")
11977 : _("Catchpoint "));
11978 ui_out_field_int (uiout, "bkptno", b->number);
11979 ui_out_text (uiout, ": ");
11980
f7f9143b
JB
11981 switch (ex)
11982 {
761269c8 11983 case ada_catch_exception:
28010a5d 11984 if (c->excep_string != NULL)
00eb2c4a
JB
11985 {
11986 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11987 struct cleanup *old_chain = make_cleanup (xfree, info);
11988
11989 ui_out_text (uiout, info);
11990 do_cleanups (old_chain);
11991 }
f7f9143b 11992 else
00eb2c4a 11993 ui_out_text (uiout, _("all Ada exceptions"));
f7f9143b
JB
11994 break;
11995
761269c8 11996 case ada_catch_exception_unhandled:
00eb2c4a 11997 ui_out_text (uiout, _("unhandled Ada exceptions"));
f7f9143b
JB
11998 break;
11999
761269c8 12000 case ada_catch_assert:
00eb2c4a 12001 ui_out_text (uiout, _("failed Ada assertions"));
f7f9143b
JB
12002 break;
12003
12004 default:
12005 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12006 break;
12007 }
12008}
12009
6149aea9
PA
12010/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12011 for all exception catchpoint kinds. */
12012
12013static void
761269c8 12014print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
12015 struct breakpoint *b, struct ui_file *fp)
12016{
28010a5d
PA
12017 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12018
6149aea9
PA
12019 switch (ex)
12020 {
761269c8 12021 case ada_catch_exception:
6149aea9 12022 fprintf_filtered (fp, "catch exception");
28010a5d
PA
12023 if (c->excep_string != NULL)
12024 fprintf_filtered (fp, " %s", c->excep_string);
6149aea9
PA
12025 break;
12026
761269c8 12027 case ada_catch_exception_unhandled:
78076abc 12028 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12029 break;
12030
761269c8 12031 case ada_catch_assert:
6149aea9
PA
12032 fprintf_filtered (fp, "catch assert");
12033 break;
12034
12035 default:
12036 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12037 }
d9b3f62e 12038 print_recreate_thread (b, fp);
6149aea9
PA
12039}
12040
f7f9143b
JB
12041/* Virtual table for "catch exception" breakpoints. */
12042
28010a5d
PA
12043static void
12044dtor_catch_exception (struct breakpoint *b)
12045{
761269c8 12046 dtor_exception (ada_catch_exception, b);
28010a5d
PA
12047}
12048
12049static struct bp_location *
12050allocate_location_catch_exception (struct breakpoint *self)
12051{
761269c8 12052 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12053}
12054
12055static void
12056re_set_catch_exception (struct breakpoint *b)
12057{
761269c8 12058 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12059}
12060
12061static void
12062check_status_catch_exception (bpstat bs)
12063{
761269c8 12064 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12065}
12066
f7f9143b 12067static enum print_stop_action
348d480f 12068print_it_catch_exception (bpstat bs)
f7f9143b 12069{
761269c8 12070 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12071}
12072
12073static void
a6d9a66e 12074print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12075{
761269c8 12076 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12077}
12078
12079static void
12080print_mention_catch_exception (struct breakpoint *b)
12081{
761269c8 12082 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12083}
12084
6149aea9
PA
12085static void
12086print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12087{
761269c8 12088 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12089}
12090
2060206e 12091static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12092
12093/* Virtual table for "catch exception unhandled" breakpoints. */
12094
28010a5d
PA
12095static void
12096dtor_catch_exception_unhandled (struct breakpoint *b)
12097{
761269c8 12098 dtor_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12099}
12100
12101static struct bp_location *
12102allocate_location_catch_exception_unhandled (struct breakpoint *self)
12103{
761269c8 12104 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12105}
12106
12107static void
12108re_set_catch_exception_unhandled (struct breakpoint *b)
12109{
761269c8 12110 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12111}
12112
12113static void
12114check_status_catch_exception_unhandled (bpstat bs)
12115{
761269c8 12116 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12117}
12118
f7f9143b 12119static enum print_stop_action
348d480f 12120print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12121{
761269c8 12122 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12123}
12124
12125static void
a6d9a66e
UW
12126print_one_catch_exception_unhandled (struct breakpoint *b,
12127 struct bp_location **last_loc)
f7f9143b 12128{
761269c8 12129 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12130}
12131
12132static void
12133print_mention_catch_exception_unhandled (struct breakpoint *b)
12134{
761269c8 12135 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12136}
12137
6149aea9
PA
12138static void
12139print_recreate_catch_exception_unhandled (struct breakpoint *b,
12140 struct ui_file *fp)
12141{
761269c8 12142 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12143}
12144
2060206e 12145static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12146
12147/* Virtual table for "catch assert" breakpoints. */
12148
28010a5d
PA
12149static void
12150dtor_catch_assert (struct breakpoint *b)
12151{
761269c8 12152 dtor_exception (ada_catch_assert, b);
28010a5d
PA
12153}
12154
12155static struct bp_location *
12156allocate_location_catch_assert (struct breakpoint *self)
12157{
761269c8 12158 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12159}
12160
12161static void
12162re_set_catch_assert (struct breakpoint *b)
12163{
761269c8 12164 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12165}
12166
12167static void
12168check_status_catch_assert (bpstat bs)
12169{
761269c8 12170 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12171}
12172
f7f9143b 12173static enum print_stop_action
348d480f 12174print_it_catch_assert (bpstat bs)
f7f9143b 12175{
761269c8 12176 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12177}
12178
12179static void
a6d9a66e 12180print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12181{
761269c8 12182 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
12183}
12184
12185static void
12186print_mention_catch_assert (struct breakpoint *b)
12187{
761269c8 12188 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
12189}
12190
6149aea9
PA
12191static void
12192print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12193{
761269c8 12194 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
12195}
12196
2060206e 12197static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 12198
f7f9143b
JB
12199/* Return a newly allocated copy of the first space-separated token
12200 in ARGSP, and then adjust ARGSP to point immediately after that
12201 token.
12202
12203 Return NULL if ARGPS does not contain any more tokens. */
12204
12205static char *
12206ada_get_next_arg (char **argsp)
12207{
12208 char *args = *argsp;
12209 char *end;
12210 char *result;
12211
0fcd72ba 12212 args = skip_spaces (args);
f7f9143b
JB
12213 if (args[0] == '\0')
12214 return NULL; /* No more arguments. */
12215
12216 /* Find the end of the current argument. */
12217
0fcd72ba 12218 end = skip_to_space (args);
f7f9143b
JB
12219
12220 /* Adjust ARGSP to point to the start of the next argument. */
12221
12222 *argsp = end;
12223
12224 /* Make a copy of the current argument and return it. */
12225
12226 result = xmalloc (end - args + 1);
12227 strncpy (result, args, end - args);
12228 result[end - args] = '\0';
12229
12230 return result;
12231}
12232
12233/* Split the arguments specified in a "catch exception" command.
12234 Set EX to the appropriate catchpoint type.
28010a5d 12235 Set EXCEP_STRING to the name of the specific exception if
5845583d
JB
12236 specified by the user.
12237 If a condition is found at the end of the arguments, the condition
12238 expression is stored in COND_STRING (memory must be deallocated
12239 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
12240
12241static void
12242catch_ada_exception_command_split (char *args,
761269c8 12243 enum ada_exception_catchpoint_kind *ex,
5845583d
JB
12244 char **excep_string,
12245 char **cond_string)
f7f9143b
JB
12246{
12247 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
12248 char *exception_name;
5845583d 12249 char *cond = NULL;
f7f9143b
JB
12250
12251 exception_name = ada_get_next_arg (&args);
5845583d
JB
12252 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
12253 {
12254 /* This is not an exception name; this is the start of a condition
12255 expression for a catchpoint on all exceptions. So, "un-get"
12256 this token, and set exception_name to NULL. */
12257 xfree (exception_name);
12258 exception_name = NULL;
12259 args -= 2;
12260 }
f7f9143b
JB
12261 make_cleanup (xfree, exception_name);
12262
5845583d 12263 /* Check to see if we have a condition. */
f7f9143b 12264
0fcd72ba 12265 args = skip_spaces (args);
5845583d
JB
12266 if (strncmp (args, "if", 2) == 0
12267 && (isspace (args[2]) || args[2] == '\0'))
12268 {
12269 args += 2;
12270 args = skip_spaces (args);
12271
12272 if (args[0] == '\0')
12273 error (_("Condition missing after `if' keyword"));
12274 cond = xstrdup (args);
12275 make_cleanup (xfree, cond);
12276
12277 args += strlen (args);
12278 }
12279
12280 /* Check that we do not have any more arguments. Anything else
12281 is unexpected. */
f7f9143b
JB
12282
12283 if (args[0] != '\0')
12284 error (_("Junk at end of expression"));
12285
12286 discard_cleanups (old_chain);
12287
12288 if (exception_name == NULL)
12289 {
12290 /* Catch all exceptions. */
761269c8 12291 *ex = ada_catch_exception;
28010a5d 12292 *excep_string = NULL;
f7f9143b
JB
12293 }
12294 else if (strcmp (exception_name, "unhandled") == 0)
12295 {
12296 /* Catch unhandled exceptions. */
761269c8 12297 *ex = ada_catch_exception_unhandled;
28010a5d 12298 *excep_string = NULL;
f7f9143b
JB
12299 }
12300 else
12301 {
12302 /* Catch a specific exception. */
761269c8 12303 *ex = ada_catch_exception;
28010a5d 12304 *excep_string = exception_name;
f7f9143b 12305 }
5845583d 12306 *cond_string = cond;
f7f9143b
JB
12307}
12308
12309/* Return the name of the symbol on which we should break in order to
12310 implement a catchpoint of the EX kind. */
12311
12312static const char *
761269c8 12313ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 12314{
3eecfa55
JB
12315 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12316
12317 gdb_assert (data->exception_info != NULL);
0259addd 12318
f7f9143b
JB
12319 switch (ex)
12320 {
761269c8 12321 case ada_catch_exception:
3eecfa55 12322 return (data->exception_info->catch_exception_sym);
f7f9143b 12323 break;
761269c8 12324 case ada_catch_exception_unhandled:
3eecfa55 12325 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 12326 break;
761269c8 12327 case ada_catch_assert:
3eecfa55 12328 return (data->exception_info->catch_assert_sym);
f7f9143b
JB
12329 break;
12330 default:
12331 internal_error (__FILE__, __LINE__,
12332 _("unexpected catchpoint kind (%d)"), ex);
12333 }
12334}
12335
12336/* Return the breakpoint ops "virtual table" used for catchpoints
12337 of the EX kind. */
12338
c0a91b2b 12339static const struct breakpoint_ops *
761269c8 12340ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
12341{
12342 switch (ex)
12343 {
761269c8 12344 case ada_catch_exception:
f7f9143b
JB
12345 return (&catch_exception_breakpoint_ops);
12346 break;
761269c8 12347 case ada_catch_exception_unhandled:
f7f9143b
JB
12348 return (&catch_exception_unhandled_breakpoint_ops);
12349 break;
761269c8 12350 case ada_catch_assert:
f7f9143b
JB
12351 return (&catch_assert_breakpoint_ops);
12352 break;
12353 default:
12354 internal_error (__FILE__, __LINE__,
12355 _("unexpected catchpoint kind (%d)"), ex);
12356 }
12357}
12358
12359/* Return the condition that will be used to match the current exception
12360 being raised with the exception that the user wants to catch. This
12361 assumes that this condition is used when the inferior just triggered
12362 an exception catchpoint.
12363
12364 The string returned is a newly allocated string that needs to be
12365 deallocated later. */
12366
12367static char *
28010a5d 12368ada_exception_catchpoint_cond_string (const char *excep_string)
f7f9143b 12369{
3d0b0fa3
JB
12370 int i;
12371
0963b4bd 12372 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 12373 runtime units that have been compiled without debugging info; if
28010a5d 12374 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
12375 exception (e.g. "constraint_error") then, during the evaluation
12376 of the condition expression, the symbol lookup on this name would
0963b4bd 12377 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
12378 may then be set only on user-defined exceptions which have the
12379 same not-fully-qualified name (e.g. my_package.constraint_error).
12380
12381 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 12382 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
12383 exception constraint_error" is rewritten into "catch exception
12384 standard.constraint_error".
12385
12386 If an exception named contraint_error is defined in another package of
12387 the inferior program, then the only way to specify this exception as a
12388 breakpoint condition is to use its fully-qualified named:
12389 e.g. my_package.constraint_error. */
12390
12391 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12392 {
28010a5d 12393 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3
JB
12394 {
12395 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
28010a5d 12396 excep_string);
3d0b0fa3
JB
12397 }
12398 }
28010a5d 12399 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
f7f9143b
JB
12400}
12401
12402/* Return the symtab_and_line that should be used to insert an exception
12403 catchpoint of the TYPE kind.
12404
28010a5d
PA
12405 EXCEP_STRING should contain the name of a specific exception that
12406 the catchpoint should catch, or NULL otherwise.
f7f9143b 12407
28010a5d
PA
12408 ADDR_STRING returns the name of the function where the real
12409 breakpoint that implements the catchpoints is set, depending on the
12410 type of catchpoint we need to create. */
f7f9143b
JB
12411
12412static struct symtab_and_line
761269c8 12413ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
c0a91b2b 12414 char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
12415{
12416 const char *sym_name;
12417 struct symbol *sym;
f7f9143b 12418
0259addd
JB
12419 /* First, find out which exception support info to use. */
12420 ada_exception_support_info_sniffer ();
12421
12422 /* Then lookup the function on which we will break in order to catch
f7f9143b 12423 the Ada exceptions requested by the user. */
f7f9143b
JB
12424 sym_name = ada_exception_sym_name (ex);
12425 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12426
f17011e0
JB
12427 /* We can assume that SYM is not NULL at this stage. If the symbol
12428 did not exist, ada_exception_support_info_sniffer would have
12429 raised an exception.
f7f9143b 12430
f17011e0
JB
12431 Also, ada_exception_support_info_sniffer should have already
12432 verified that SYM is a function symbol. */
12433 gdb_assert (sym != NULL);
12434 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
12435
12436 /* Set ADDR_STRING. */
f7f9143b
JB
12437 *addr_string = xstrdup (sym_name);
12438
f7f9143b 12439 /* Set OPS. */
4b9eee8c 12440 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 12441
f17011e0 12442 return find_function_start_sal (sym, 1);
f7f9143b
JB
12443}
12444
b4a5b78b 12445/* Create an Ada exception catchpoint.
f7f9143b 12446
b4a5b78b 12447 EX_KIND is the kind of exception catchpoint to be created.
5845583d 12448
2df4d1d5
JB
12449 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
12450 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12451 of the exception to which this catchpoint applies. When not NULL,
12452 the string must be allocated on the heap, and its deallocation
12453 is no longer the responsibility of the caller.
12454
12455 COND_STRING, if not NULL, is the catchpoint condition. This string
12456 must be allocated on the heap, and its deallocation is no longer
12457 the responsibility of the caller.
f7f9143b 12458
b4a5b78b
JB
12459 TEMPFLAG, if nonzero, means that the underlying breakpoint
12460 should be temporary.
28010a5d 12461
b4a5b78b 12462 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 12463
349774ef 12464void
28010a5d 12465create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 12466 enum ada_exception_catchpoint_kind ex_kind,
28010a5d 12467 char *excep_string,
5845583d 12468 char *cond_string,
28010a5d 12469 int tempflag,
349774ef 12470 int disabled,
28010a5d
PA
12471 int from_tty)
12472{
12473 struct ada_catchpoint *c;
b4a5b78b
JB
12474 char *addr_string = NULL;
12475 const struct breakpoint_ops *ops = NULL;
12476 struct symtab_and_line sal
12477 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
28010a5d
PA
12478
12479 c = XNEW (struct ada_catchpoint);
12480 init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string,
349774ef 12481 ops, tempflag, disabled, from_tty);
28010a5d
PA
12482 c->excep_string = excep_string;
12483 create_excep_cond_exprs (c);
5845583d
JB
12484 if (cond_string != NULL)
12485 set_breakpoint_condition (&c->base, cond_string, from_tty);
3ea46bff 12486 install_breakpoint (0, &c->base, 1);
f7f9143b
JB
12487}
12488
9ac4176b
PA
12489/* Implement the "catch exception" command. */
12490
12491static void
12492catch_ada_exception_command (char *arg, int from_tty,
12493 struct cmd_list_element *command)
12494{
12495 struct gdbarch *gdbarch = get_current_arch ();
12496 int tempflag;
761269c8 12497 enum ada_exception_catchpoint_kind ex_kind;
28010a5d 12498 char *excep_string = NULL;
5845583d 12499 char *cond_string = NULL;
9ac4176b
PA
12500
12501 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12502
12503 if (!arg)
12504 arg = "";
b4a5b78b
JB
12505 catch_ada_exception_command_split (arg, &ex_kind, &excep_string,
12506 &cond_string);
12507 create_ada_exception_catchpoint (gdbarch, ex_kind,
12508 excep_string, cond_string,
349774ef
JB
12509 tempflag, 1 /* enabled */,
12510 from_tty);
9ac4176b
PA
12511}
12512
b4a5b78b 12513/* Split the arguments specified in a "catch assert" command.
5845583d 12514
b4a5b78b
JB
12515 ARGS contains the command's arguments (or the empty string if
12516 no arguments were passed).
5845583d
JB
12517
12518 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 12519 (the memory needs to be deallocated after use). */
5845583d 12520
b4a5b78b
JB
12521static void
12522catch_ada_assert_command_split (char *args, char **cond_string)
f7f9143b 12523{
5845583d 12524 args = skip_spaces (args);
f7f9143b 12525
5845583d
JB
12526 /* Check whether a condition was provided. */
12527 if (strncmp (args, "if", 2) == 0
12528 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 12529 {
5845583d 12530 args += 2;
0fcd72ba 12531 args = skip_spaces (args);
5845583d
JB
12532 if (args[0] == '\0')
12533 error (_("condition missing after `if' keyword"));
12534 *cond_string = xstrdup (args);
f7f9143b
JB
12535 }
12536
5845583d
JB
12537 /* Otherwise, there should be no other argument at the end of
12538 the command. */
12539 else if (args[0] != '\0')
12540 error (_("Junk at end of arguments."));
f7f9143b
JB
12541}
12542
9ac4176b
PA
12543/* Implement the "catch assert" command. */
12544
12545static void
12546catch_assert_command (char *arg, int from_tty,
12547 struct cmd_list_element *command)
12548{
12549 struct gdbarch *gdbarch = get_current_arch ();
12550 int tempflag;
5845583d 12551 char *cond_string = NULL;
9ac4176b
PA
12552
12553 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12554
12555 if (!arg)
12556 arg = "";
b4a5b78b 12557 catch_ada_assert_command_split (arg, &cond_string);
761269c8 12558 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
b4a5b78b 12559 NULL, cond_string,
349774ef
JB
12560 tempflag, 1 /* enabled */,
12561 from_tty);
9ac4176b 12562}
778865d3
JB
12563
12564/* Return non-zero if the symbol SYM is an Ada exception object. */
12565
12566static int
12567ada_is_exception_sym (struct symbol *sym)
12568{
12569 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
12570
12571 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
12572 && SYMBOL_CLASS (sym) != LOC_BLOCK
12573 && SYMBOL_CLASS (sym) != LOC_CONST
12574 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
12575 && type_name != NULL && strcmp (type_name, "exception") == 0);
12576}
12577
12578/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12579 Ada exception object. This matches all exceptions except the ones
12580 defined by the Ada language. */
12581
12582static int
12583ada_is_non_standard_exception_sym (struct symbol *sym)
12584{
12585 int i;
12586
12587 if (!ada_is_exception_sym (sym))
12588 return 0;
12589
12590 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12591 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
12592 return 0; /* A standard exception. */
12593
12594 /* Numeric_Error is also a standard exception, so exclude it.
12595 See the STANDARD_EXC description for more details as to why
12596 this exception is not listed in that array. */
12597 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
12598 return 0;
12599
12600 return 1;
12601}
12602
12603/* A helper function for qsort, comparing two struct ada_exc_info
12604 objects.
12605
12606 The comparison is determined first by exception name, and then
12607 by exception address. */
12608
12609static int
12610compare_ada_exception_info (const void *a, const void *b)
12611{
12612 const struct ada_exc_info *exc_a = (struct ada_exc_info *) a;
12613 const struct ada_exc_info *exc_b = (struct ada_exc_info *) b;
12614 int result;
12615
12616 result = strcmp (exc_a->name, exc_b->name);
12617 if (result != 0)
12618 return result;
12619
12620 if (exc_a->addr < exc_b->addr)
12621 return -1;
12622 if (exc_a->addr > exc_b->addr)
12623 return 1;
12624
12625 return 0;
12626}
12627
12628/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12629 routine, but keeping the first SKIP elements untouched.
12630
12631 All duplicates are also removed. */
12632
12633static void
12634sort_remove_dups_ada_exceptions_list (VEC(ada_exc_info) **exceptions,
12635 int skip)
12636{
12637 struct ada_exc_info *to_sort
12638 = VEC_address (ada_exc_info, *exceptions) + skip;
12639 int to_sort_len
12640 = VEC_length (ada_exc_info, *exceptions) - skip;
12641 int i, j;
12642
12643 qsort (to_sort, to_sort_len, sizeof (struct ada_exc_info),
12644 compare_ada_exception_info);
12645
12646 for (i = 1, j = 1; i < to_sort_len; i++)
12647 if (compare_ada_exception_info (&to_sort[i], &to_sort[j - 1]) != 0)
12648 to_sort[j++] = to_sort[i];
12649 to_sort_len = j;
12650 VEC_truncate(ada_exc_info, *exceptions, skip + to_sort_len);
12651}
12652
12653/* A function intended as the "name_matcher" callback in the struct
12654 quick_symbol_functions' expand_symtabs_matching method.
12655
12656 SEARCH_NAME is the symbol's search name.
12657
12658 If USER_DATA is not NULL, it is a pointer to a regext_t object
12659 used to match the symbol (by natural name). Otherwise, when USER_DATA
12660 is null, no filtering is performed, and all symbols are a positive
12661 match. */
12662
12663static int
12664ada_exc_search_name_matches (const char *search_name, void *user_data)
12665{
12666 regex_t *preg = user_data;
12667
12668 if (preg == NULL)
12669 return 1;
12670
12671 /* In Ada, the symbol "search name" is a linkage name, whereas
12672 the regular expression used to do the matching refers to
12673 the natural name. So match against the decoded name. */
12674 return (regexec (preg, ada_decode (search_name), 0, NULL, 0) == 0);
12675}
12676
12677/* Add all exceptions defined by the Ada standard whose name match
12678 a regular expression.
12679
12680 If PREG is not NULL, then this regexp_t object is used to
12681 perform the symbol name matching. Otherwise, no name-based
12682 filtering is performed.
12683
12684 EXCEPTIONS is a vector of exceptions to which matching exceptions
12685 gets pushed. */
12686
12687static void
12688ada_add_standard_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
12689{
12690 int i;
12691
12692 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12693 {
12694 if (preg == NULL
12695 || regexec (preg, standard_exc[i], 0, NULL, 0) == 0)
12696 {
12697 struct bound_minimal_symbol msymbol
12698 = ada_lookup_simple_minsym (standard_exc[i]);
12699
12700 if (msymbol.minsym != NULL)
12701 {
12702 struct ada_exc_info info
77e371c0 12703 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
778865d3
JB
12704
12705 VEC_safe_push (ada_exc_info, *exceptions, &info);
12706 }
12707 }
12708 }
12709}
12710
12711/* Add all Ada exceptions defined locally and accessible from the given
12712 FRAME.
12713
12714 If PREG is not NULL, then this regexp_t object is used to
12715 perform the symbol name matching. Otherwise, no name-based
12716 filtering is performed.
12717
12718 EXCEPTIONS is a vector of exceptions to which matching exceptions
12719 gets pushed. */
12720
12721static void
12722ada_add_exceptions_from_frame (regex_t *preg, struct frame_info *frame,
12723 VEC(ada_exc_info) **exceptions)
12724{
12725 struct block *block = get_frame_block (frame, 0);
12726
12727 while (block != 0)
12728 {
12729 struct block_iterator iter;
12730 struct symbol *sym;
12731
12732 ALL_BLOCK_SYMBOLS (block, iter, sym)
12733 {
12734 switch (SYMBOL_CLASS (sym))
12735 {
12736 case LOC_TYPEDEF:
12737 case LOC_BLOCK:
12738 case LOC_CONST:
12739 break;
12740 default:
12741 if (ada_is_exception_sym (sym))
12742 {
12743 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
12744 SYMBOL_VALUE_ADDRESS (sym)};
12745
12746 VEC_safe_push (ada_exc_info, *exceptions, &info);
12747 }
12748 }
12749 }
12750 if (BLOCK_FUNCTION (block) != NULL)
12751 break;
12752 block = BLOCK_SUPERBLOCK (block);
12753 }
12754}
12755
12756/* Add all exceptions defined globally whose name name match
12757 a regular expression, excluding standard exceptions.
12758
12759 The reason we exclude standard exceptions is that they need
12760 to be handled separately: Standard exceptions are defined inside
12761 a runtime unit which is normally not compiled with debugging info,
12762 and thus usually do not show up in our symbol search. However,
12763 if the unit was in fact built with debugging info, we need to
12764 exclude them because they would duplicate the entry we found
12765 during the special loop that specifically searches for those
12766 standard exceptions.
12767
12768 If PREG is not NULL, then this regexp_t object is used to
12769 perform the symbol name matching. Otherwise, no name-based
12770 filtering is performed.
12771
12772 EXCEPTIONS is a vector of exceptions to which matching exceptions
12773 gets pushed. */
12774
12775static void
12776ada_add_global_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
12777{
12778 struct objfile *objfile;
12779 struct symtab *s;
12780
bb4142cf
DE
12781 expand_symtabs_matching (NULL, ada_exc_search_name_matches,
12782 VARIABLES_DOMAIN, preg);
778865d3
JB
12783
12784 ALL_PRIMARY_SYMTABS (objfile, s)
12785 {
12786 struct blockvector *bv = BLOCKVECTOR (s);
12787 int i;
12788
12789 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
12790 {
12791 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
12792 struct block_iterator iter;
12793 struct symbol *sym;
12794
12795 ALL_BLOCK_SYMBOLS (b, iter, sym)
12796 if (ada_is_non_standard_exception_sym (sym)
12797 && (preg == NULL
12798 || regexec (preg, SYMBOL_NATURAL_NAME (sym),
12799 0, NULL, 0) == 0))
12800 {
12801 struct ada_exc_info info
12802 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
12803
12804 VEC_safe_push (ada_exc_info, *exceptions, &info);
12805 }
12806 }
12807 }
12808}
12809
12810/* Implements ada_exceptions_list with the regular expression passed
12811 as a regex_t, rather than a string.
12812
12813 If not NULL, PREG is used to filter out exceptions whose names
12814 do not match. Otherwise, all exceptions are listed. */
12815
12816static VEC(ada_exc_info) *
12817ada_exceptions_list_1 (regex_t *preg)
12818{
12819 VEC(ada_exc_info) *result = NULL;
12820 struct cleanup *old_chain
12821 = make_cleanup (VEC_cleanup (ada_exc_info), &result);
12822 int prev_len;
12823
12824 /* First, list the known standard exceptions. These exceptions
12825 need to be handled separately, as they are usually defined in
12826 runtime units that have been compiled without debugging info. */
12827
12828 ada_add_standard_exceptions (preg, &result);
12829
12830 /* Next, find all exceptions whose scope is local and accessible
12831 from the currently selected frame. */
12832
12833 if (has_stack_frames ())
12834 {
12835 prev_len = VEC_length (ada_exc_info, result);
12836 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
12837 &result);
12838 if (VEC_length (ada_exc_info, result) > prev_len)
12839 sort_remove_dups_ada_exceptions_list (&result, prev_len);
12840 }
12841
12842 /* Add all exceptions whose scope is global. */
12843
12844 prev_len = VEC_length (ada_exc_info, result);
12845 ada_add_global_exceptions (preg, &result);
12846 if (VEC_length (ada_exc_info, result) > prev_len)
12847 sort_remove_dups_ada_exceptions_list (&result, prev_len);
12848
12849 discard_cleanups (old_chain);
12850 return result;
12851}
12852
12853/* Return a vector of ada_exc_info.
12854
12855 If REGEXP is NULL, all exceptions are included in the result.
12856 Otherwise, it should contain a valid regular expression,
12857 and only the exceptions whose names match that regular expression
12858 are included in the result.
12859
12860 The exceptions are sorted in the following order:
12861 - Standard exceptions (defined by the Ada language), in
12862 alphabetical order;
12863 - Exceptions only visible from the current frame, in
12864 alphabetical order;
12865 - Exceptions whose scope is global, in alphabetical order. */
12866
12867VEC(ada_exc_info) *
12868ada_exceptions_list (const char *regexp)
12869{
12870 VEC(ada_exc_info) *result = NULL;
12871 struct cleanup *old_chain = NULL;
12872 regex_t reg;
12873
12874 if (regexp != NULL)
12875 old_chain = compile_rx_or_error (&reg, regexp,
12876 _("invalid regular expression"));
12877
12878 result = ada_exceptions_list_1 (regexp != NULL ? &reg : NULL);
12879
12880 if (old_chain != NULL)
12881 do_cleanups (old_chain);
12882 return result;
12883}
12884
12885/* Implement the "info exceptions" command. */
12886
12887static void
12888info_exceptions_command (char *regexp, int from_tty)
12889{
12890 VEC(ada_exc_info) *exceptions;
12891 struct cleanup *cleanup;
12892 struct gdbarch *gdbarch = get_current_arch ();
12893 int ix;
12894 struct ada_exc_info *info;
12895
12896 exceptions = ada_exceptions_list (regexp);
12897 cleanup = make_cleanup (VEC_cleanup (ada_exc_info), &exceptions);
12898
12899 if (regexp != NULL)
12900 printf_filtered
12901 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
12902 else
12903 printf_filtered (_("All defined Ada exceptions:\n"));
12904
12905 for (ix = 0; VEC_iterate(ada_exc_info, exceptions, ix, info); ix++)
12906 printf_filtered ("%s: %s\n", info->name, paddress (gdbarch, info->addr));
12907
12908 do_cleanups (cleanup);
12909}
12910
4c4b4cd2
PH
12911 /* Operators */
12912/* Information about operators given special treatment in functions
12913 below. */
12914/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
12915
12916#define ADA_OPERATORS \
12917 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
12918 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
12919 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
12920 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
12921 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
12922 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
12923 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
12924 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
12925 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
12926 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
12927 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
12928 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
12929 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
12930 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
12931 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
12932 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
12933 OP_DEFN (OP_OTHERS, 1, 1, 0) \
12934 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
12935 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
12936
12937static void
554794dc
SDJ
12938ada_operator_length (const struct expression *exp, int pc, int *oplenp,
12939 int *argsp)
4c4b4cd2
PH
12940{
12941 switch (exp->elts[pc - 1].opcode)
12942 {
76a01679 12943 default:
4c4b4cd2
PH
12944 operator_length_standard (exp, pc, oplenp, argsp);
12945 break;
12946
12947#define OP_DEFN(op, len, args, binop) \
12948 case op: *oplenp = len; *argsp = args; break;
12949 ADA_OPERATORS;
12950#undef OP_DEFN
52ce6436
PH
12951
12952 case OP_AGGREGATE:
12953 *oplenp = 3;
12954 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
12955 break;
12956
12957 case OP_CHOICES:
12958 *oplenp = 3;
12959 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
12960 break;
4c4b4cd2
PH
12961 }
12962}
12963
c0201579
JK
12964/* Implementation of the exp_descriptor method operator_check. */
12965
12966static int
12967ada_operator_check (struct expression *exp, int pos,
12968 int (*objfile_func) (struct objfile *objfile, void *data),
12969 void *data)
12970{
12971 const union exp_element *const elts = exp->elts;
12972 struct type *type = NULL;
12973
12974 switch (elts[pos].opcode)
12975 {
12976 case UNOP_IN_RANGE:
12977 case UNOP_QUAL:
12978 type = elts[pos + 1].type;
12979 break;
12980
12981 default:
12982 return operator_check_standard (exp, pos, objfile_func, data);
12983 }
12984
12985 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
12986
12987 if (type && TYPE_OBJFILE (type)
12988 && (*objfile_func) (TYPE_OBJFILE (type), data))
12989 return 1;
12990
12991 return 0;
12992}
12993
4c4b4cd2
PH
12994static char *
12995ada_op_name (enum exp_opcode opcode)
12996{
12997 switch (opcode)
12998 {
76a01679 12999 default:
4c4b4cd2 13000 return op_name_standard (opcode);
52ce6436 13001
4c4b4cd2
PH
13002#define OP_DEFN(op, len, args, binop) case op: return #op;
13003 ADA_OPERATORS;
13004#undef OP_DEFN
52ce6436
PH
13005
13006 case OP_AGGREGATE:
13007 return "OP_AGGREGATE";
13008 case OP_CHOICES:
13009 return "OP_CHOICES";
13010 case OP_NAME:
13011 return "OP_NAME";
4c4b4cd2
PH
13012 }
13013}
13014
13015/* As for operator_length, but assumes PC is pointing at the first
13016 element of the operator, and gives meaningful results only for the
52ce6436 13017 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
13018
13019static void
76a01679
JB
13020ada_forward_operator_length (struct expression *exp, int pc,
13021 int *oplenp, int *argsp)
4c4b4cd2 13022{
76a01679 13023 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
13024 {
13025 default:
13026 *oplenp = *argsp = 0;
13027 break;
52ce6436 13028
4c4b4cd2
PH
13029#define OP_DEFN(op, len, args, binop) \
13030 case op: *oplenp = len; *argsp = args; break;
13031 ADA_OPERATORS;
13032#undef OP_DEFN
52ce6436
PH
13033
13034 case OP_AGGREGATE:
13035 *oplenp = 3;
13036 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13037 break;
13038
13039 case OP_CHOICES:
13040 *oplenp = 3;
13041 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13042 break;
13043
13044 case OP_STRING:
13045 case OP_NAME:
13046 {
13047 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13048
52ce6436
PH
13049 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13050 *argsp = 0;
13051 break;
13052 }
4c4b4cd2
PH
13053 }
13054}
13055
13056static int
13057ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13058{
13059 enum exp_opcode op = exp->elts[elt].opcode;
13060 int oplen, nargs;
13061 int pc = elt;
13062 int i;
76a01679 13063
4c4b4cd2
PH
13064 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13065
76a01679 13066 switch (op)
4c4b4cd2 13067 {
76a01679 13068 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13069 case OP_ATR_FIRST:
13070 case OP_ATR_LAST:
13071 case OP_ATR_LENGTH:
13072 case OP_ATR_IMAGE:
13073 case OP_ATR_MAX:
13074 case OP_ATR_MIN:
13075 case OP_ATR_MODULUS:
13076 case OP_ATR_POS:
13077 case OP_ATR_SIZE:
13078 case OP_ATR_TAG:
13079 case OP_ATR_VAL:
13080 break;
13081
13082 case UNOP_IN_RANGE:
13083 case UNOP_QUAL:
323e0a4a
AC
13084 /* XXX: gdb_sprint_host_address, type_sprint */
13085 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13086 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13087 fprintf_filtered (stream, " (");
13088 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13089 fprintf_filtered (stream, ")");
13090 break;
13091 case BINOP_IN_BOUNDS:
52ce6436
PH
13092 fprintf_filtered (stream, " (%d)",
13093 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13094 break;
13095 case TERNOP_IN_RANGE:
13096 break;
13097
52ce6436
PH
13098 case OP_AGGREGATE:
13099 case OP_OTHERS:
13100 case OP_DISCRETE_RANGE:
13101 case OP_POSITIONAL:
13102 case OP_CHOICES:
13103 break;
13104
13105 case OP_NAME:
13106 case OP_STRING:
13107 {
13108 char *name = &exp->elts[elt + 2].string;
13109 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 13110
52ce6436
PH
13111 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13112 break;
13113 }
13114
4c4b4cd2
PH
13115 default:
13116 return dump_subexp_body_standard (exp, stream, elt);
13117 }
13118
13119 elt += oplen;
13120 for (i = 0; i < nargs; i += 1)
13121 elt = dump_subexp (exp, stream, elt);
13122
13123 return elt;
13124}
13125
13126/* The Ada extension of print_subexp (q.v.). */
13127
76a01679
JB
13128static void
13129ada_print_subexp (struct expression *exp, int *pos,
13130 struct ui_file *stream, enum precedence prec)
4c4b4cd2 13131{
52ce6436 13132 int oplen, nargs, i;
4c4b4cd2
PH
13133 int pc = *pos;
13134 enum exp_opcode op = exp->elts[pc].opcode;
13135
13136 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13137
52ce6436 13138 *pos += oplen;
4c4b4cd2
PH
13139 switch (op)
13140 {
13141 default:
52ce6436 13142 *pos -= oplen;
4c4b4cd2
PH
13143 print_subexp_standard (exp, pos, stream, prec);
13144 return;
13145
13146 case OP_VAR_VALUE:
4c4b4cd2
PH
13147 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13148 return;
13149
13150 case BINOP_IN_BOUNDS:
323e0a4a 13151 /* XXX: sprint_subexp */
4c4b4cd2 13152 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13153 fputs_filtered (" in ", stream);
4c4b4cd2 13154 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13155 fputs_filtered ("'range", stream);
4c4b4cd2 13156 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
13157 fprintf_filtered (stream, "(%ld)",
13158 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
13159 return;
13160
13161 case TERNOP_IN_RANGE:
4c4b4cd2 13162 if (prec >= PREC_EQUAL)
76a01679 13163 fputs_filtered ("(", stream);
323e0a4a 13164 /* XXX: sprint_subexp */
4c4b4cd2 13165 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13166 fputs_filtered (" in ", stream);
4c4b4cd2
PH
13167 print_subexp (exp, pos, stream, PREC_EQUAL);
13168 fputs_filtered (" .. ", stream);
13169 print_subexp (exp, pos, stream, PREC_EQUAL);
13170 if (prec >= PREC_EQUAL)
76a01679
JB
13171 fputs_filtered (")", stream);
13172 return;
4c4b4cd2
PH
13173
13174 case OP_ATR_FIRST:
13175 case OP_ATR_LAST:
13176 case OP_ATR_LENGTH:
13177 case OP_ATR_IMAGE:
13178 case OP_ATR_MAX:
13179 case OP_ATR_MIN:
13180 case OP_ATR_MODULUS:
13181 case OP_ATR_POS:
13182 case OP_ATR_SIZE:
13183 case OP_ATR_TAG:
13184 case OP_ATR_VAL:
4c4b4cd2 13185 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
13186 {
13187 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
13188 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13189 &type_print_raw_options);
76a01679
JB
13190 *pos += 3;
13191 }
4c4b4cd2 13192 else
76a01679 13193 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
13194 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13195 if (nargs > 1)
76a01679
JB
13196 {
13197 int tem;
5b4ee69b 13198
76a01679
JB
13199 for (tem = 1; tem < nargs; tem += 1)
13200 {
13201 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13202 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13203 }
13204 fputs_filtered (")", stream);
13205 }
4c4b4cd2 13206 return;
14f9c5c9 13207
4c4b4cd2 13208 case UNOP_QUAL:
4c4b4cd2
PH
13209 type_print (exp->elts[pc + 1].type, "", stream, 0);
13210 fputs_filtered ("'(", stream);
13211 print_subexp (exp, pos, stream, PREC_PREFIX);
13212 fputs_filtered (")", stream);
13213 return;
14f9c5c9 13214
4c4b4cd2 13215 case UNOP_IN_RANGE:
323e0a4a 13216 /* XXX: sprint_subexp */
4c4b4cd2 13217 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13218 fputs_filtered (" in ", stream);
79d43c61
TT
13219 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13220 &type_print_raw_options);
4c4b4cd2 13221 return;
52ce6436
PH
13222
13223 case OP_DISCRETE_RANGE:
13224 print_subexp (exp, pos, stream, PREC_SUFFIX);
13225 fputs_filtered ("..", stream);
13226 print_subexp (exp, pos, stream, PREC_SUFFIX);
13227 return;
13228
13229 case OP_OTHERS:
13230 fputs_filtered ("others => ", stream);
13231 print_subexp (exp, pos, stream, PREC_SUFFIX);
13232 return;
13233
13234 case OP_CHOICES:
13235 for (i = 0; i < nargs-1; i += 1)
13236 {
13237 if (i > 0)
13238 fputs_filtered ("|", stream);
13239 print_subexp (exp, pos, stream, PREC_SUFFIX);
13240 }
13241 fputs_filtered (" => ", stream);
13242 print_subexp (exp, pos, stream, PREC_SUFFIX);
13243 return;
13244
13245 case OP_POSITIONAL:
13246 print_subexp (exp, pos, stream, PREC_SUFFIX);
13247 return;
13248
13249 case OP_AGGREGATE:
13250 fputs_filtered ("(", stream);
13251 for (i = 0; i < nargs; i += 1)
13252 {
13253 if (i > 0)
13254 fputs_filtered (", ", stream);
13255 print_subexp (exp, pos, stream, PREC_SUFFIX);
13256 }
13257 fputs_filtered (")", stream);
13258 return;
4c4b4cd2
PH
13259 }
13260}
14f9c5c9
AS
13261
13262/* Table mapping opcodes into strings for printing operators
13263 and precedences of the operators. */
13264
d2e4a39e
AS
13265static const struct op_print ada_op_print_tab[] = {
13266 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13267 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13268 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13269 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13270 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13271 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13272 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13273 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13274 {"<=", BINOP_LEQ, PREC_ORDER, 0},
13275 {">=", BINOP_GEQ, PREC_ORDER, 0},
13276 {">", BINOP_GTR, PREC_ORDER, 0},
13277 {"<", BINOP_LESS, PREC_ORDER, 0},
13278 {">>", BINOP_RSH, PREC_SHIFT, 0},
13279 {"<<", BINOP_LSH, PREC_SHIFT, 0},
13280 {"+", BINOP_ADD, PREC_ADD, 0},
13281 {"-", BINOP_SUB, PREC_ADD, 0},
13282 {"&", BINOP_CONCAT, PREC_ADD, 0},
13283 {"*", BINOP_MUL, PREC_MUL, 0},
13284 {"/", BINOP_DIV, PREC_MUL, 0},
13285 {"rem", BINOP_REM, PREC_MUL, 0},
13286 {"mod", BINOP_MOD, PREC_MUL, 0},
13287 {"**", BINOP_EXP, PREC_REPEAT, 0},
13288 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13289 {"-", UNOP_NEG, PREC_PREFIX, 0},
13290 {"+", UNOP_PLUS, PREC_PREFIX, 0},
13291 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13292 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13293 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
13294 {".all", UNOP_IND, PREC_SUFFIX, 1},
13295 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13296 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
d2e4a39e 13297 {NULL, 0, 0, 0}
14f9c5c9
AS
13298};
13299\f
72d5681a
PH
13300enum ada_primitive_types {
13301 ada_primitive_type_int,
13302 ada_primitive_type_long,
13303 ada_primitive_type_short,
13304 ada_primitive_type_char,
13305 ada_primitive_type_float,
13306 ada_primitive_type_double,
13307 ada_primitive_type_void,
13308 ada_primitive_type_long_long,
13309 ada_primitive_type_long_double,
13310 ada_primitive_type_natural,
13311 ada_primitive_type_positive,
13312 ada_primitive_type_system_address,
13313 nr_ada_primitive_types
13314};
6c038f32
PH
13315
13316static void
d4a9a881 13317ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
13318 struct language_arch_info *lai)
13319{
d4a9a881 13320 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 13321
72d5681a 13322 lai->primitive_type_vector
d4a9a881 13323 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 13324 struct type *);
e9bb382b
UW
13325
13326 lai->primitive_type_vector [ada_primitive_type_int]
13327 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13328 0, "integer");
13329 lai->primitive_type_vector [ada_primitive_type_long]
13330 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13331 0, "long_integer");
13332 lai->primitive_type_vector [ada_primitive_type_short]
13333 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13334 0, "short_integer");
13335 lai->string_char_type
13336 = lai->primitive_type_vector [ada_primitive_type_char]
13337 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
13338 lai->primitive_type_vector [ada_primitive_type_float]
13339 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13340 "float", NULL);
13341 lai->primitive_type_vector [ada_primitive_type_double]
13342 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13343 "long_float", NULL);
13344 lai->primitive_type_vector [ada_primitive_type_long_long]
13345 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13346 0, "long_long_integer");
13347 lai->primitive_type_vector [ada_primitive_type_long_double]
13348 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13349 "long_long_float", NULL);
13350 lai->primitive_type_vector [ada_primitive_type_natural]
13351 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13352 0, "natural");
13353 lai->primitive_type_vector [ada_primitive_type_positive]
13354 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13355 0, "positive");
13356 lai->primitive_type_vector [ada_primitive_type_void]
13357 = builtin->builtin_void;
13358
13359 lai->primitive_type_vector [ada_primitive_type_system_address]
13360 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
72d5681a
PH
13361 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
13362 = "system__address";
fbb06eb1 13363
47e729a8 13364 lai->bool_type_symbol = NULL;
fbb06eb1 13365 lai->bool_type_default = builtin->builtin_bool;
6c038f32 13366}
6c038f32
PH
13367\f
13368 /* Language vector */
13369
13370/* Not really used, but needed in the ada_language_defn. */
13371
13372static void
6c7a06a3 13373emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 13374{
6c7a06a3 13375 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
13376}
13377
13378static int
13379parse (void)
13380{
13381 warnings_issued = 0;
13382 return ada_parse ();
13383}
13384
13385static const struct exp_descriptor ada_exp_descriptor = {
13386 ada_print_subexp,
13387 ada_operator_length,
c0201579 13388 ada_operator_check,
6c038f32
PH
13389 ada_op_name,
13390 ada_dump_subexp_body,
13391 ada_evaluate_subexp
13392};
13393
1a119f36 13394/* Implement the "la_get_symbol_name_cmp" language_defn method
74ccd7f5
JB
13395 for Ada. */
13396
1a119f36
JB
13397static symbol_name_cmp_ftype
13398ada_get_symbol_name_cmp (const char *lookup_name)
74ccd7f5
JB
13399{
13400 if (should_use_wild_match (lookup_name))
13401 return wild_match;
13402 else
13403 return compare_names;
13404}
13405
a5ee536b
JB
13406/* Implement the "la_read_var_value" language_defn method for Ada. */
13407
13408static struct value *
13409ada_read_var_value (struct symbol *var, struct frame_info *frame)
13410{
13411 struct block *frame_block = NULL;
13412 struct symbol *renaming_sym = NULL;
13413
13414 /* The only case where default_read_var_value is not sufficient
13415 is when VAR is a renaming... */
13416 if (frame)
13417 frame_block = get_frame_block (frame, NULL);
13418 if (frame_block)
13419 renaming_sym = ada_find_renaming_symbol (var, frame_block);
13420 if (renaming_sym != NULL)
13421 return ada_read_renaming_var_value (renaming_sym, frame_block);
13422
13423 /* This is a typical case where we expect the default_read_var_value
13424 function to work. */
13425 return default_read_var_value (var, frame);
13426}
13427
6c038f32
PH
13428const struct language_defn ada_language_defn = {
13429 "ada", /* Language name */
6abde28f 13430 "Ada",
6c038f32 13431 language_ada,
6c038f32 13432 range_check_off,
6c038f32
PH
13433 case_sensitive_on, /* Yes, Ada is case-insensitive, but
13434 that's not quite what this means. */
6c038f32 13435 array_row_major,
9a044a89 13436 macro_expansion_no,
6c038f32
PH
13437 &ada_exp_descriptor,
13438 parse,
13439 ada_error,
13440 resolve,
13441 ada_printchar, /* Print a character constant */
13442 ada_printstr, /* Function to print string constant */
13443 emit_char, /* Function to print single char (not used) */
6c038f32 13444 ada_print_type, /* Print a type using appropriate syntax */
be942545 13445 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
13446 ada_val_print, /* Print a value using appropriate syntax */
13447 ada_value_print, /* Print a top-level value */
a5ee536b 13448 ada_read_var_value, /* la_read_var_value */
6c038f32 13449 NULL, /* Language specific skip_trampoline */
2b2d9e11 13450 NULL, /* name_of_this */
6c038f32
PH
13451 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
13452 basic_lookup_transparent_type, /* lookup_transparent_type */
13453 ada_la_decode, /* Language specific symbol demangler */
0963b4bd
MS
13454 NULL, /* Language specific
13455 class_name_from_physname */
6c038f32
PH
13456 ada_op_print_tab, /* expression operators for printing */
13457 0, /* c-style arrays */
13458 1, /* String lower bound */
6c038f32 13459 ada_get_gdb_completer_word_break_characters,
41d27058 13460 ada_make_symbol_completion_list,
72d5681a 13461 ada_language_arch_info,
e79af960 13462 ada_print_array_index,
41f1b697 13463 default_pass_by_reference,
ae6a3a4c 13464 c_get_string,
1a119f36 13465 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
f8eba3c6 13466 ada_iterate_over_symbols,
a53b64ea 13467 &ada_varobj_ops,
6c038f32
PH
13468 LANG_MAGIC
13469};
13470
2c0b251b
PA
13471/* Provide a prototype to silence -Wmissing-prototypes. */
13472extern initialize_file_ftype _initialize_ada_language;
13473
5bf03f13
JB
13474/* Command-list for the "set/show ada" prefix command. */
13475static struct cmd_list_element *set_ada_list;
13476static struct cmd_list_element *show_ada_list;
13477
13478/* Implement the "set ada" prefix command. */
13479
13480static void
13481set_ada_command (char *arg, int from_tty)
13482{
13483 printf_unfiltered (_(\
13484"\"set ada\" must be followed by the name of a setting.\n"));
13485 help_list (set_ada_list, "set ada ", -1, gdb_stdout);
13486}
13487
13488/* Implement the "show ada" prefix command. */
13489
13490static void
13491show_ada_command (char *args, int from_tty)
13492{
13493 cmd_show_list (show_ada_list, from_tty, "");
13494}
13495
2060206e
PA
13496static void
13497initialize_ada_catchpoint_ops (void)
13498{
13499 struct breakpoint_ops *ops;
13500
13501 initialize_breakpoint_ops ();
13502
13503 ops = &catch_exception_breakpoint_ops;
13504 *ops = bkpt_breakpoint_ops;
13505 ops->dtor = dtor_catch_exception;
13506 ops->allocate_location = allocate_location_catch_exception;
13507 ops->re_set = re_set_catch_exception;
13508 ops->check_status = check_status_catch_exception;
13509 ops->print_it = print_it_catch_exception;
13510 ops->print_one = print_one_catch_exception;
13511 ops->print_mention = print_mention_catch_exception;
13512 ops->print_recreate = print_recreate_catch_exception;
13513
13514 ops = &catch_exception_unhandled_breakpoint_ops;
13515 *ops = bkpt_breakpoint_ops;
13516 ops->dtor = dtor_catch_exception_unhandled;
13517 ops->allocate_location = allocate_location_catch_exception_unhandled;
13518 ops->re_set = re_set_catch_exception_unhandled;
13519 ops->check_status = check_status_catch_exception_unhandled;
13520 ops->print_it = print_it_catch_exception_unhandled;
13521 ops->print_one = print_one_catch_exception_unhandled;
13522 ops->print_mention = print_mention_catch_exception_unhandled;
13523 ops->print_recreate = print_recreate_catch_exception_unhandled;
13524
13525 ops = &catch_assert_breakpoint_ops;
13526 *ops = bkpt_breakpoint_ops;
13527 ops->dtor = dtor_catch_assert;
13528 ops->allocate_location = allocate_location_catch_assert;
13529 ops->re_set = re_set_catch_assert;
13530 ops->check_status = check_status_catch_assert;
13531 ops->print_it = print_it_catch_assert;
13532 ops->print_one = print_one_catch_assert;
13533 ops->print_mention = print_mention_catch_assert;
13534 ops->print_recreate = print_recreate_catch_assert;
13535}
13536
3d9434b5
JB
13537/* This module's 'new_objfile' observer. */
13538
13539static void
13540ada_new_objfile_observer (struct objfile *objfile)
13541{
13542 ada_clear_symbol_cache ();
13543}
13544
13545/* This module's 'free_objfile' observer. */
13546
13547static void
13548ada_free_objfile_observer (struct objfile *objfile)
13549{
13550 ada_clear_symbol_cache ();
13551}
13552
d2e4a39e 13553void
6c038f32 13554_initialize_ada_language (void)
14f9c5c9 13555{
6c038f32
PH
13556 add_language (&ada_language_defn);
13557
2060206e
PA
13558 initialize_ada_catchpoint_ops ();
13559
5bf03f13
JB
13560 add_prefix_cmd ("ada", no_class, set_ada_command,
13561 _("Prefix command for changing Ada-specfic settings"),
13562 &set_ada_list, "set ada ", 0, &setlist);
13563
13564 add_prefix_cmd ("ada", no_class, show_ada_command,
13565 _("Generic command for showing Ada-specific settings."),
13566 &show_ada_list, "show ada ", 0, &showlist);
13567
13568 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13569 &trust_pad_over_xvs, _("\
13570Enable or disable an optimization trusting PAD types over XVS types"), _("\
13571Show whether an optimization trusting PAD types over XVS types is activated"),
13572 _("\
13573This is related to the encoding used by the GNAT compiler. The debugger\n\
13574should normally trust the contents of PAD types, but certain older versions\n\
13575of GNAT have a bug that sometimes causes the information in the PAD type\n\
13576to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13577work around this bug. It is always safe to turn this option \"off\", but\n\
13578this incurs a slight performance penalty, so it is recommended to NOT change\n\
13579this option to \"off\" unless necessary."),
13580 NULL, NULL, &set_ada_list, &show_ada_list);
13581
9ac4176b
PA
13582 add_catch_command ("exception", _("\
13583Catch Ada exceptions, when raised.\n\
13584With an argument, catch only exceptions with the given name."),
13585 catch_ada_exception_command,
13586 NULL,
13587 CATCH_PERMANENT,
13588 CATCH_TEMPORARY);
13589 add_catch_command ("assert", _("\
13590Catch failed Ada assertions, when raised.\n\
13591With an argument, catch only exceptions with the given name."),
13592 catch_assert_command,
13593 NULL,
13594 CATCH_PERMANENT,
13595 CATCH_TEMPORARY);
13596
6c038f32 13597 varsize_limit = 65536;
6c038f32 13598
778865d3
JB
13599 add_info ("exceptions", info_exceptions_command,
13600 _("\
13601List all Ada exception names.\n\
13602If a regular expression is passed as an argument, only those matching\n\
13603the regular expression are listed."));
13604
c6044dd1
JB
13605 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
13606 _("Set Ada maintenance-related variables."),
13607 &maint_set_ada_cmdlist, "maintenance set ada ",
13608 0/*allow-unknown*/, &maintenance_set_cmdlist);
13609
13610 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
13611 _("Show Ada maintenance-related variables"),
13612 &maint_show_ada_cmdlist, "maintenance show ada ",
13613 0/*allow-unknown*/, &maintenance_show_cmdlist);
13614
13615 add_setshow_boolean_cmd
13616 ("ignore-descriptive-types", class_maintenance,
13617 &ada_ignore_descriptive_types_p,
13618 _("Set whether descriptive types generated by GNAT should be ignored."),
13619 _("Show whether descriptive types generated by GNAT should be ignored."),
13620 _("\
13621When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13622DWARF attribute."),
13623 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
13624
6c038f32
PH
13625 obstack_init (&symbol_list_obstack);
13626
13627 decoded_names_store = htab_create_alloc
13628 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
13629 NULL, xcalloc, xfree);
6b69afc4 13630
3d9434b5
JB
13631 /* The ada-lang observers. */
13632 observer_attach_new_objfile (ada_new_objfile_observer);
13633 observer_attach_free_objfile (ada_free_objfile_observer);
e802dbe0 13634 observer_attach_inferior_exit (ada_inferior_exit);
ee01b665
JB
13635
13636 /* Setup various context-specific data. */
e802dbe0 13637 ada_inferior_data
8e260fc0 13638 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
ee01b665
JB
13639 ada_pspace_data_handle
13640 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14f9c5c9 13641}