]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
Adjust start-of-function braces to be compatible with Clang
[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;
0c9c3474
SA
1984 create_static_range_type (range_type, value_type (low),
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
11aa919a
PMR
2253 /* If our value is a pointer, then dereference it. Likewise if
2254 the value is a reference. Make sure that this operation does not
2255 cause the target type to be fixed, as this would indirectly cause
2256 this array to be decoded. The rest of the routine assumes that
2257 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2258 and "value_ind" routines to perform the dereferencing, as opposed
2259 to using "ada_coerce_ref" or "ada_value_ind". */
2260 arr = coerce_ref (arr);
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));
9f1f738a 2409 type = value_type (v);
d2e4a39e 2410 bytes = (unsigned char *) alloca (len);
53ba8333 2411 read_memory (value_address (v) + offset, bytes, len);
14f9c5c9 2412 }
d2e4a39e 2413 else
14f9c5c9
AS
2414 {
2415 v = allocate_value (type);
0fd88904 2416 bytes = (unsigned char *) value_contents (obj) + offset;
14f9c5c9 2417 }
d2e4a39e
AS
2418
2419 if (obj != NULL)
14f9c5c9 2420 {
53ba8333 2421 long new_offset = offset;
5b4ee69b 2422
74bcbdf3 2423 set_value_component_location (v, obj);
9bbda503
AC
2424 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2425 set_value_bitsize (v, bit_size);
df407dfe 2426 if (value_bitpos (v) >= HOST_CHAR_BIT)
4c4b4cd2 2427 {
53ba8333 2428 ++new_offset;
9bbda503 2429 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
4c4b4cd2 2430 }
53ba8333
JB
2431 set_value_offset (v, new_offset);
2432
2433 /* Also set the parent value. This is needed when trying to
2434 assign a new value (in inferior memory). */
2435 set_value_parent (v, obj);
14f9c5c9
AS
2436 }
2437 else
9bbda503 2438 set_value_bitsize (v, bit_size);
0fd88904 2439 unpacked = (unsigned char *) value_contents (v);
14f9c5c9
AS
2440
2441 srcBitsLeft = bit_size;
2442 nsrc = len;
2443 ntarg = TYPE_LENGTH (type);
2444 sign = 0;
2445 if (bit_size == 0)
2446 {
2447 memset (unpacked, 0, TYPE_LENGTH (type));
2448 return v;
2449 }
50810684 2450 else if (gdbarch_bits_big_endian (get_type_arch (type)))
14f9c5c9 2451 {
d2e4a39e 2452 src = len - 1;
1265e4aa
JB
2453 if (has_negatives (type)
2454 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2455 sign = ~0;
d2e4a39e
AS
2456
2457 unusedLS =
4c4b4cd2
PH
2458 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2459 % HOST_CHAR_BIT;
14f9c5c9
AS
2460
2461 switch (TYPE_CODE (type))
4c4b4cd2
PH
2462 {
2463 case TYPE_CODE_ARRAY:
2464 case TYPE_CODE_UNION:
2465 case TYPE_CODE_STRUCT:
2466 /* Non-scalar values must be aligned at a byte boundary... */
2467 accumSize =
2468 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2469 /* ... And are placed at the beginning (most-significant) bytes
2470 of the target. */
529cad9c 2471 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
0056e4d5 2472 ntarg = targ + 1;
4c4b4cd2
PH
2473 break;
2474 default:
2475 accumSize = 0;
2476 targ = TYPE_LENGTH (type) - 1;
2477 break;
2478 }
14f9c5c9 2479 }
d2e4a39e 2480 else
14f9c5c9
AS
2481 {
2482 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2483
2484 src = targ = 0;
2485 unusedLS = bit_offset;
2486 accumSize = 0;
2487
d2e4a39e 2488 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2489 sign = ~0;
14f9c5c9 2490 }
d2e4a39e 2491
14f9c5c9
AS
2492 accum = 0;
2493 while (nsrc > 0)
2494 {
2495 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2496 part of the value. */
d2e4a39e 2497 unsigned int unusedMSMask =
4c4b4cd2
PH
2498 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2499 1;
2500 /* Sign-extend bits for this byte. */
14f9c5c9 2501 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2502
d2e4a39e 2503 accum |=
4c4b4cd2 2504 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2505 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2506 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2
PH
2507 {
2508 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2509 accumSize -= HOST_CHAR_BIT;
2510 accum >>= HOST_CHAR_BIT;
2511 ntarg -= 1;
2512 targ += delta;
2513 }
14f9c5c9
AS
2514 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2515 unusedLS = 0;
2516 nsrc -= 1;
2517 src += delta;
2518 }
2519 while (ntarg > 0)
2520 {
2521 accum |= sign << accumSize;
2522 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2523 accumSize -= HOST_CHAR_BIT;
2524 accum >>= HOST_CHAR_BIT;
2525 ntarg -= 1;
2526 targ += delta;
2527 }
2528
2529 return v;
2530}
d2e4a39e 2531
14f9c5c9
AS
2532/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2533 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2534 not overlap. */
14f9c5c9 2535static void
fc1a4b47 2536move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2537 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2538{
2539 unsigned int accum, mask;
2540 int accum_bits, chunk_size;
2541
2542 target += targ_offset / HOST_CHAR_BIT;
2543 targ_offset %= HOST_CHAR_BIT;
2544 source += src_offset / HOST_CHAR_BIT;
2545 src_offset %= HOST_CHAR_BIT;
50810684 2546 if (bits_big_endian_p)
14f9c5c9
AS
2547 {
2548 accum = (unsigned char) *source;
2549 source += 1;
2550 accum_bits = HOST_CHAR_BIT - src_offset;
2551
d2e4a39e 2552 while (n > 0)
4c4b4cd2
PH
2553 {
2554 int unused_right;
5b4ee69b 2555
4c4b4cd2
PH
2556 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2557 accum_bits += HOST_CHAR_BIT;
2558 source += 1;
2559 chunk_size = HOST_CHAR_BIT - targ_offset;
2560 if (chunk_size > n)
2561 chunk_size = n;
2562 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2563 mask = ((1 << chunk_size) - 1) << unused_right;
2564 *target =
2565 (*target & ~mask)
2566 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2567 n -= chunk_size;
2568 accum_bits -= chunk_size;
2569 target += 1;
2570 targ_offset = 0;
2571 }
14f9c5c9
AS
2572 }
2573 else
2574 {
2575 accum = (unsigned char) *source >> src_offset;
2576 source += 1;
2577 accum_bits = HOST_CHAR_BIT - src_offset;
2578
d2e4a39e 2579 while (n > 0)
4c4b4cd2
PH
2580 {
2581 accum = accum + ((unsigned char) *source << accum_bits);
2582 accum_bits += HOST_CHAR_BIT;
2583 source += 1;
2584 chunk_size = HOST_CHAR_BIT - targ_offset;
2585 if (chunk_size > n)
2586 chunk_size = n;
2587 mask = ((1 << chunk_size) - 1) << targ_offset;
2588 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2589 n -= chunk_size;
2590 accum_bits -= chunk_size;
2591 accum >>= chunk_size;
2592 target += 1;
2593 targ_offset = 0;
2594 }
14f9c5c9
AS
2595 }
2596}
2597
14f9c5c9
AS
2598/* Store the contents of FROMVAL into the location of TOVAL.
2599 Return a new value with the location of TOVAL and contents of
2600 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2601 floating-point or non-scalar types. */
14f9c5c9 2602
d2e4a39e
AS
2603static struct value *
2604ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2605{
df407dfe
AC
2606 struct type *type = value_type (toval);
2607 int bits = value_bitsize (toval);
14f9c5c9 2608
52ce6436
PH
2609 toval = ada_coerce_ref (toval);
2610 fromval = ada_coerce_ref (fromval);
2611
2612 if (ada_is_direct_array_type (value_type (toval)))
2613 toval = ada_coerce_to_simple_array (toval);
2614 if (ada_is_direct_array_type (value_type (fromval)))
2615 fromval = ada_coerce_to_simple_array (fromval);
2616
88e3b34b 2617 if (!deprecated_value_modifiable (toval))
323e0a4a 2618 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2619
d2e4a39e 2620 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2621 && bits > 0
d2e4a39e 2622 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2623 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2624 {
df407dfe
AC
2625 int len = (value_bitpos (toval)
2626 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2627 int from_size;
948f8e3d 2628 gdb_byte *buffer = alloca (len);
d2e4a39e 2629 struct value *val;
42ae5230 2630 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2631
2632 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2633 fromval = value_cast (type, fromval);
14f9c5c9 2634
52ce6436 2635 read_memory (to_addr, buffer, len);
aced2898
PH
2636 from_size = value_bitsize (fromval);
2637 if (from_size == 0)
2638 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2639 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2640 move_bits (buffer, value_bitpos (toval),
50810684 2641 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2642 else
50810684
UW
2643 move_bits (buffer, value_bitpos (toval),
2644 value_contents (fromval), 0, bits, 0);
972daa01 2645 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2646
14f9c5c9 2647 val = value_copy (toval);
0fd88904 2648 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2649 TYPE_LENGTH (type));
04624583 2650 deprecated_set_value_type (val, type);
d2e4a39e 2651
14f9c5c9
AS
2652 return val;
2653 }
2654
2655 return value_assign (toval, fromval);
2656}
2657
2658
52ce6436
PH
2659/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2660 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2661 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2662 * COMPONENT, and not the inferior's memory. The current contents
2663 * of COMPONENT are ignored. */
2664static void
2665value_assign_to_component (struct value *container, struct value *component,
2666 struct value *val)
2667{
2668 LONGEST offset_in_container =
42ae5230 2669 (LONGEST) (value_address (component) - value_address (container));
52ce6436
PH
2670 int bit_offset_in_container =
2671 value_bitpos (component) - value_bitpos (container);
2672 int bits;
2673
2674 val = value_cast (value_type (component), val);
2675
2676 if (value_bitsize (component) == 0)
2677 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2678 else
2679 bits = value_bitsize (component);
2680
50810684 2681 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
52ce6436
PH
2682 move_bits (value_contents_writeable (container) + offset_in_container,
2683 value_bitpos (container) + bit_offset_in_container,
2684 value_contents (val),
2685 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
50810684 2686 bits, 1);
52ce6436
PH
2687 else
2688 move_bits (value_contents_writeable (container) + offset_in_container,
2689 value_bitpos (container) + bit_offset_in_container,
50810684 2690 value_contents (val), 0, bits, 0);
52ce6436
PH
2691}
2692
4c4b4cd2
PH
2693/* The value of the element of array ARR at the ARITY indices given in IND.
2694 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2695 thereto. */
2696
d2e4a39e
AS
2697struct value *
2698ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2699{
2700 int k;
d2e4a39e
AS
2701 struct value *elt;
2702 struct type *elt_type;
14f9c5c9
AS
2703
2704 elt = ada_coerce_to_simple_array (arr);
2705
df407dfe 2706 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2707 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2708 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2709 return value_subscript_packed (elt, arity, ind);
2710
2711 for (k = 0; k < arity; k += 1)
2712 {
2713 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2714 error (_("too many subscripts (%d expected)"), k);
2497b498 2715 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2716 }
2717 return elt;
2718}
2719
2720/* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2721 value of the element of *ARR at the ARITY indices given in
4c4b4cd2 2722 IND. Does not read the entire array into memory. */
14f9c5c9 2723
2c0b251b 2724static struct value *
d2e4a39e 2725ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
4c4b4cd2 2726 struct value **ind)
14f9c5c9
AS
2727{
2728 int k;
2729
2730 for (k = 0; k < arity; k += 1)
2731 {
2732 LONGEST lwb, upb;
14f9c5c9
AS
2733
2734 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2735 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2736 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2737 value_copy (arr));
14f9c5c9 2738 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2497b498 2739 arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
14f9c5c9
AS
2740 type = TYPE_TARGET_TYPE (type);
2741 }
2742
2743 return value_ind (arr);
2744}
2745
0b5d8877 2746/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
f5938064
JG
2747 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2748 elements starting at index LOW. The lower bound of this array is LOW, as
0963b4bd 2749 per Ada rules. */
0b5d8877 2750static struct value *
f5938064
JG
2751ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2752 int low, int high)
0b5d8877 2753{
b0dd7688 2754 struct type *type0 = ada_check_typedef (type);
6c038f32 2755 CORE_ADDR base = value_as_address (array_ptr)
b0dd7688
JB
2756 + ((low - ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0)))
2757 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
0c9c3474
SA
2758 struct type *index_type
2759 = create_static_range_type (NULL,
2760 TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)),
2761 low, high);
6c038f32 2762 struct type *slice_type =
b0dd7688 2763 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
5b4ee69b 2764
f5938064 2765 return value_at_lazy (slice_type, base);
0b5d8877
PH
2766}
2767
2768
2769static struct value *
2770ada_value_slice (struct value *array, int low, int high)
2771{
b0dd7688 2772 struct type *type = ada_check_typedef (value_type (array));
0c9c3474
SA
2773 struct type *index_type
2774 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
6c038f32 2775 struct type *slice_type =
0b5d8877 2776 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
5b4ee69b 2777
6c038f32 2778 return value_cast (slice_type, value_slice (array, low, high - low + 1));
0b5d8877
PH
2779}
2780
14f9c5c9
AS
2781/* If type is a record type in the form of a standard GNAT array
2782 descriptor, returns the number of dimensions for type. If arr is a
2783 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2784 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2785
2786int
d2e4a39e 2787ada_array_arity (struct type *type)
14f9c5c9
AS
2788{
2789 int arity;
2790
2791 if (type == NULL)
2792 return 0;
2793
2794 type = desc_base_type (type);
2795
2796 arity = 0;
d2e4a39e 2797 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2798 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2799 else
2800 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2801 {
4c4b4cd2 2802 arity += 1;
61ee279c 2803 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2804 }
d2e4a39e 2805
14f9c5c9
AS
2806 return arity;
2807}
2808
2809/* If TYPE is a record type in the form of a standard GNAT array
2810 descriptor or a simple array type, returns the element type for
2811 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2812 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2813
d2e4a39e
AS
2814struct type *
2815ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2816{
2817 type = desc_base_type (type);
2818
d2e4a39e 2819 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2820 {
2821 int k;
d2e4a39e 2822 struct type *p_array_type;
14f9c5c9 2823
556bdfd4 2824 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
2825
2826 k = ada_array_arity (type);
2827 if (k == 0)
4c4b4cd2 2828 return NULL;
d2e4a39e 2829
4c4b4cd2 2830 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2831 if (nindices >= 0 && k > nindices)
4c4b4cd2 2832 k = nindices;
d2e4a39e 2833 while (k > 0 && p_array_type != NULL)
4c4b4cd2 2834 {
61ee279c 2835 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
2836 k -= 1;
2837 }
14f9c5c9
AS
2838 return p_array_type;
2839 }
2840 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2841 {
2842 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
2843 {
2844 type = TYPE_TARGET_TYPE (type);
2845 nindices -= 1;
2846 }
14f9c5c9
AS
2847 return type;
2848 }
2849
2850 return NULL;
2851}
2852
4c4b4cd2 2853/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
2854 Does not examine memory. Throws an error if N is invalid or TYPE
2855 is not an array type. NAME is the name of the Ada attribute being
2856 evaluated ('range, 'first, 'last, or 'length); it is used in building
2857 the error message. */
14f9c5c9 2858
1eea4ebd
UW
2859static struct type *
2860ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 2861{
4c4b4cd2
PH
2862 struct type *result_type;
2863
14f9c5c9
AS
2864 type = desc_base_type (type);
2865
1eea4ebd
UW
2866 if (n < 0 || n > ada_array_arity (type))
2867 error (_("invalid dimension number to '%s"), name);
14f9c5c9 2868
4c4b4cd2 2869 if (ada_is_simple_array_type (type))
14f9c5c9
AS
2870 {
2871 int i;
2872
2873 for (i = 1; i < n; i += 1)
4c4b4cd2 2874 type = TYPE_TARGET_TYPE (type);
262452ec 2875 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
2876 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2877 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 2878 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
2879 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2880 result_type = NULL;
14f9c5c9 2881 }
d2e4a39e 2882 else
1eea4ebd
UW
2883 {
2884 result_type = desc_index_type (desc_bounds_type (type), n);
2885 if (result_type == NULL)
2886 error (_("attempt to take bound of something that is not an array"));
2887 }
2888
2889 return result_type;
14f9c5c9
AS
2890}
2891
2892/* Given that arr is an array type, returns the lower bound of the
2893 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 2894 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
2895 array-descriptor type. It works for other arrays with bounds supplied
2896 by run-time quantities other than discriminants. */
14f9c5c9 2897
abb68b3e 2898static LONGEST
fb5e3d5c 2899ada_array_bound_from_type (struct type *arr_type, int n, int which)
14f9c5c9 2900{
8a48ac95 2901 struct type *type, *index_type_desc, *index_type;
1ce677a4 2902 int i;
262452ec
JK
2903
2904 gdb_assert (which == 0 || which == 1);
14f9c5c9 2905
ad82864c
JB
2906 if (ada_is_constrained_packed_array_type (arr_type))
2907 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 2908
4c4b4cd2 2909 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 2910 return (LONGEST) - which;
14f9c5c9
AS
2911
2912 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2913 type = TYPE_TARGET_TYPE (arr_type);
2914 else
2915 type = arr_type;
2916
2917 index_type_desc = ada_find_parallel_type (type, "___XA");
28c85d6c 2918 ada_fixup_array_indexes_type (index_type_desc);
262452ec 2919 if (index_type_desc != NULL)
28c85d6c
JB
2920 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
2921 NULL);
262452ec 2922 else
8a48ac95
JB
2923 {
2924 struct type *elt_type = check_typedef (type);
2925
2926 for (i = 1; i < n; i++)
2927 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
2928
2929 index_type = TYPE_INDEX_TYPE (elt_type);
2930 }
262452ec 2931
43bbcdc2
PH
2932 return
2933 (LONGEST) (which == 0
2934 ? ada_discrete_type_low_bound (index_type)
2935 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
2936}
2937
2938/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
2939 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2940 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 2941 supplied by run-time quantities other than discriminants. */
14f9c5c9 2942
1eea4ebd 2943static LONGEST
4dc81987 2944ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 2945{
df407dfe 2946 struct type *arr_type = value_type (arr);
14f9c5c9 2947
ad82864c
JB
2948 if (ada_is_constrained_packed_array_type (arr_type))
2949 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 2950 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 2951 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 2952 else
1eea4ebd 2953 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
2954}
2955
2956/* Given that arr is an array value, returns the length of the
2957 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
2958 supplied by run-time quantities other than discriminants.
2959 Does not work for arrays indexed by enumeration types with representation
2960 clauses at the moment. */
14f9c5c9 2961
1eea4ebd 2962static LONGEST
d2e4a39e 2963ada_array_length (struct value *arr, int n)
14f9c5c9 2964{
df407dfe 2965 struct type *arr_type = ada_check_typedef (value_type (arr));
14f9c5c9 2966
ad82864c
JB
2967 if (ada_is_constrained_packed_array_type (arr_type))
2968 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 2969
4c4b4cd2 2970 if (ada_is_simple_array_type (arr_type))
1eea4ebd
UW
2971 return (ada_array_bound_from_type (arr_type, n, 1)
2972 - ada_array_bound_from_type (arr_type, n, 0) + 1);
14f9c5c9 2973 else
1eea4ebd
UW
2974 return (value_as_long (desc_one_bound (desc_bounds (arr), n, 1))
2975 - value_as_long (desc_one_bound (desc_bounds (arr), n, 0)) + 1);
4c4b4cd2
PH
2976}
2977
2978/* An empty array whose type is that of ARR_TYPE (an array type),
2979 with bounds LOW to LOW-1. */
2980
2981static struct value *
2982empty_array (struct type *arr_type, int low)
2983{
b0dd7688 2984 struct type *arr_type0 = ada_check_typedef (arr_type);
0c9c3474
SA
2985 struct type *index_type
2986 = create_static_range_type
2987 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
b0dd7688 2988 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 2989
0b5d8877 2990 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 2991}
14f9c5c9 2992\f
d2e4a39e 2993
4c4b4cd2 2994 /* Name resolution */
14f9c5c9 2995
4c4b4cd2
PH
2996/* The "decoded" name for the user-definable Ada operator corresponding
2997 to OP. */
14f9c5c9 2998
d2e4a39e 2999static const char *
4c4b4cd2 3000ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
3001{
3002 int i;
3003
4c4b4cd2 3004 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
3005 {
3006 if (ada_opname_table[i].op == op)
4c4b4cd2 3007 return ada_opname_table[i].decoded;
14f9c5c9 3008 }
323e0a4a 3009 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
3010}
3011
3012
4c4b4cd2
PH
3013/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3014 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3015 undefined namespace) and converts operators that are
3016 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
3017 non-null, it provides a preferred result type [at the moment, only
3018 type void has any effect---causing procedures to be preferred over
3019 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 3020 return type is preferred. May change (expand) *EXP. */
14f9c5c9 3021
4c4b4cd2
PH
3022static void
3023resolve (struct expression **expp, int void_context_p)
14f9c5c9 3024{
30b15541
UW
3025 struct type *context_type = NULL;
3026 int pc = 0;
3027
3028 if (void_context_p)
3029 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3030
3031 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
3032}
3033
4c4b4cd2
PH
3034/* Resolve the operator of the subexpression beginning at
3035 position *POS of *EXPP. "Resolving" consists of replacing
3036 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3037 with their resolutions, replacing built-in operators with
3038 function calls to user-defined operators, where appropriate, and,
3039 when DEPROCEDURE_P is non-zero, converting function-valued variables
3040 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3041 are as in ada_resolve, above. */
14f9c5c9 3042
d2e4a39e 3043static struct value *
4c4b4cd2 3044resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
76a01679 3045 struct type *context_type)
14f9c5c9
AS
3046{
3047 int pc = *pos;
3048 int i;
4c4b4cd2 3049 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 3050 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
3051 struct value **argvec; /* Vector of operand types (alloca'ed). */
3052 int nargs; /* Number of operands. */
52ce6436 3053 int oplen;
14f9c5c9
AS
3054
3055 argvec = NULL;
3056 nargs = 0;
3057 exp = *expp;
3058
52ce6436
PH
3059 /* Pass one: resolve operands, saving their types and updating *pos,
3060 if needed. */
14f9c5c9
AS
3061 switch (op)
3062 {
4c4b4cd2
PH
3063 case OP_FUNCALL:
3064 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
3065 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3066 *pos += 7;
4c4b4cd2
PH
3067 else
3068 {
3069 *pos += 3;
3070 resolve_subexp (expp, pos, 0, NULL);
3071 }
3072 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
3073 break;
3074
14f9c5c9 3075 case UNOP_ADDR:
4c4b4cd2
PH
3076 *pos += 1;
3077 resolve_subexp (expp, pos, 0, NULL);
3078 break;
3079
52ce6436
PH
3080 case UNOP_QUAL:
3081 *pos += 3;
17466c1a 3082 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
3083 break;
3084
52ce6436 3085 case OP_ATR_MODULUS:
4c4b4cd2
PH
3086 case OP_ATR_SIZE:
3087 case OP_ATR_TAG:
4c4b4cd2
PH
3088 case OP_ATR_FIRST:
3089 case OP_ATR_LAST:
3090 case OP_ATR_LENGTH:
3091 case OP_ATR_POS:
3092 case OP_ATR_VAL:
4c4b4cd2
PH
3093 case OP_ATR_MIN:
3094 case OP_ATR_MAX:
52ce6436
PH
3095 case TERNOP_IN_RANGE:
3096 case BINOP_IN_BOUNDS:
3097 case UNOP_IN_RANGE:
3098 case OP_AGGREGATE:
3099 case OP_OTHERS:
3100 case OP_CHOICES:
3101 case OP_POSITIONAL:
3102 case OP_DISCRETE_RANGE:
3103 case OP_NAME:
3104 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3105 *pos += oplen;
14f9c5c9
AS
3106 break;
3107
3108 case BINOP_ASSIGN:
3109 {
4c4b4cd2
PH
3110 struct value *arg1;
3111
3112 *pos += 1;
3113 arg1 = resolve_subexp (expp, pos, 0, NULL);
3114 if (arg1 == NULL)
3115 resolve_subexp (expp, pos, 1, NULL);
3116 else
df407dfe 3117 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 3118 break;
14f9c5c9
AS
3119 }
3120
4c4b4cd2 3121 case UNOP_CAST:
4c4b4cd2
PH
3122 *pos += 3;
3123 nargs = 1;
3124 break;
14f9c5c9 3125
4c4b4cd2
PH
3126 case BINOP_ADD:
3127 case BINOP_SUB:
3128 case BINOP_MUL:
3129 case BINOP_DIV:
3130 case BINOP_REM:
3131 case BINOP_MOD:
3132 case BINOP_EXP:
3133 case BINOP_CONCAT:
3134 case BINOP_LOGICAL_AND:
3135 case BINOP_LOGICAL_OR:
3136 case BINOP_BITWISE_AND:
3137 case BINOP_BITWISE_IOR:
3138 case BINOP_BITWISE_XOR:
14f9c5c9 3139
4c4b4cd2
PH
3140 case BINOP_EQUAL:
3141 case BINOP_NOTEQUAL:
3142 case BINOP_LESS:
3143 case BINOP_GTR:
3144 case BINOP_LEQ:
3145 case BINOP_GEQ:
14f9c5c9 3146
4c4b4cd2
PH
3147 case BINOP_REPEAT:
3148 case BINOP_SUBSCRIPT:
3149 case BINOP_COMMA:
40c8aaa9
JB
3150 *pos += 1;
3151 nargs = 2;
3152 break;
14f9c5c9 3153
4c4b4cd2
PH
3154 case UNOP_NEG:
3155 case UNOP_PLUS:
3156 case UNOP_LOGICAL_NOT:
3157 case UNOP_ABS:
3158 case UNOP_IND:
3159 *pos += 1;
3160 nargs = 1;
3161 break;
14f9c5c9 3162
4c4b4cd2
PH
3163 case OP_LONG:
3164 case OP_DOUBLE:
3165 case OP_VAR_VALUE:
3166 *pos += 4;
3167 break;
14f9c5c9 3168
4c4b4cd2
PH
3169 case OP_TYPE:
3170 case OP_BOOL:
3171 case OP_LAST:
4c4b4cd2
PH
3172 case OP_INTERNALVAR:
3173 *pos += 3;
3174 break;
14f9c5c9 3175
4c4b4cd2
PH
3176 case UNOP_MEMVAL:
3177 *pos += 3;
3178 nargs = 1;
3179 break;
3180
67f3407f
DJ
3181 case OP_REGISTER:
3182 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3183 break;
3184
4c4b4cd2
PH
3185 case STRUCTOP_STRUCT:
3186 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3187 nargs = 1;
3188 break;
3189
4c4b4cd2 3190 case TERNOP_SLICE:
4c4b4cd2
PH
3191 *pos += 1;
3192 nargs = 3;
3193 break;
3194
52ce6436 3195 case OP_STRING:
14f9c5c9 3196 break;
4c4b4cd2
PH
3197
3198 default:
323e0a4a 3199 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3200 }
3201
76a01679 3202 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
4c4b4cd2
PH
3203 for (i = 0; i < nargs; i += 1)
3204 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3205 argvec[i] = NULL;
3206 exp = *expp;
3207
3208 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3209 switch (op)
3210 {
3211 default:
3212 break;
3213
14f9c5c9 3214 case OP_VAR_VALUE:
4c4b4cd2 3215 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
3216 {
3217 struct ada_symbol_info *candidates;
3218 int n_candidates;
3219
3220 n_candidates =
3221 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3222 (exp->elts[pc + 2].symbol),
3223 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3224 &candidates);
76a01679
JB
3225
3226 if (n_candidates > 1)
3227 {
3228 /* Types tend to get re-introduced locally, so if there
3229 are any local symbols that are not types, first filter
3230 out all types. */
3231 int j;
3232 for (j = 0; j < n_candidates; j += 1)
3233 switch (SYMBOL_CLASS (candidates[j].sym))
3234 {
3235 case LOC_REGISTER:
3236 case LOC_ARG:
3237 case LOC_REF_ARG:
76a01679
JB
3238 case LOC_REGPARM_ADDR:
3239 case LOC_LOCAL:
76a01679 3240 case LOC_COMPUTED:
76a01679
JB
3241 goto FoundNonType;
3242 default:
3243 break;
3244 }
3245 FoundNonType:
3246 if (j < n_candidates)
3247 {
3248 j = 0;
3249 while (j < n_candidates)
3250 {
3251 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
3252 {
3253 candidates[j] = candidates[n_candidates - 1];
3254 n_candidates -= 1;
3255 }
3256 else
3257 j += 1;
3258 }
3259 }
3260 }
3261
3262 if (n_candidates == 0)
323e0a4a 3263 error (_("No definition found for %s"),
76a01679
JB
3264 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3265 else if (n_candidates == 1)
3266 i = 0;
3267 else if (deprocedure_p
3268 && !is_nonfunction (candidates, n_candidates))
3269 {
06d5cf63
JB
3270 i = ada_resolve_function
3271 (candidates, n_candidates, NULL, 0,
3272 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3273 context_type);
76a01679 3274 if (i < 0)
323e0a4a 3275 error (_("Could not find a match for %s"),
76a01679
JB
3276 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3277 }
3278 else
3279 {
323e0a4a 3280 printf_filtered (_("Multiple matches for %s\n"),
76a01679
JB
3281 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3282 user_select_syms (candidates, n_candidates, 1);
3283 i = 0;
3284 }
3285
3286 exp->elts[pc + 1].block = candidates[i].block;
3287 exp->elts[pc + 2].symbol = candidates[i].sym;
1265e4aa
JB
3288 if (innermost_block == NULL
3289 || contained_in (candidates[i].block, innermost_block))
76a01679
JB
3290 innermost_block = candidates[i].block;
3291 }
3292
3293 if (deprocedure_p
3294 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3295 == TYPE_CODE_FUNC))
3296 {
3297 replace_operator_with_call (expp, pc, 0, 0,
3298 exp->elts[pc + 2].symbol,
3299 exp->elts[pc + 1].block);
3300 exp = *expp;
3301 }
14f9c5c9
AS
3302 break;
3303
3304 case OP_FUNCALL:
3305 {
4c4b4cd2 3306 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3307 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2
PH
3308 {
3309 struct ada_symbol_info *candidates;
3310 int n_candidates;
3311
3312 n_candidates =
76a01679
JB
3313 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3314 (exp->elts[pc + 5].symbol),
3315 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3316 &candidates);
4c4b4cd2
PH
3317 if (n_candidates == 1)
3318 i = 0;
3319 else
3320 {
06d5cf63
JB
3321 i = ada_resolve_function
3322 (candidates, n_candidates,
3323 argvec, nargs,
3324 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3325 context_type);
4c4b4cd2 3326 if (i < 0)
323e0a4a 3327 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3328 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3329 }
3330
3331 exp->elts[pc + 4].block = candidates[i].block;
3332 exp->elts[pc + 5].symbol = candidates[i].sym;
1265e4aa
JB
3333 if (innermost_block == NULL
3334 || contained_in (candidates[i].block, innermost_block))
4c4b4cd2
PH
3335 innermost_block = candidates[i].block;
3336 }
14f9c5c9
AS
3337 }
3338 break;
3339 case BINOP_ADD:
3340 case BINOP_SUB:
3341 case BINOP_MUL:
3342 case BINOP_DIV:
3343 case BINOP_REM:
3344 case BINOP_MOD:
3345 case BINOP_CONCAT:
3346 case BINOP_BITWISE_AND:
3347 case BINOP_BITWISE_IOR:
3348 case BINOP_BITWISE_XOR:
3349 case BINOP_EQUAL:
3350 case BINOP_NOTEQUAL:
3351 case BINOP_LESS:
3352 case BINOP_GTR:
3353 case BINOP_LEQ:
3354 case BINOP_GEQ:
3355 case BINOP_EXP:
3356 case UNOP_NEG:
3357 case UNOP_PLUS:
3358 case UNOP_LOGICAL_NOT:
3359 case UNOP_ABS:
3360 if (possible_user_operator_p (op, argvec))
4c4b4cd2
PH
3361 {
3362 struct ada_symbol_info *candidates;
3363 int n_candidates;
3364
3365 n_candidates =
3366 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3367 (struct block *) NULL, VAR_DOMAIN,
4eeaa230 3368 &candidates);
4c4b4cd2 3369 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
76a01679 3370 ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3371 if (i < 0)
3372 break;
3373
76a01679
JB
3374 replace_operator_with_call (expp, pc, nargs, 1,
3375 candidates[i].sym, candidates[i].block);
4c4b4cd2
PH
3376 exp = *expp;
3377 }
14f9c5c9 3378 break;
4c4b4cd2
PH
3379
3380 case OP_TYPE:
b3dbf008 3381 case OP_REGISTER:
4c4b4cd2 3382 return NULL;
14f9c5c9
AS
3383 }
3384
3385 *pos = pc;
3386 return evaluate_subexp_type (exp, pos);
3387}
3388
3389/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3390 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3391 a non-pointer. */
14f9c5c9 3392/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3393 liberal. */
14f9c5c9
AS
3394
3395static int
4dc81987 3396ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3397{
61ee279c
PH
3398 ftype = ada_check_typedef (ftype);
3399 atype = ada_check_typedef (atype);
14f9c5c9
AS
3400
3401 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3402 ftype = TYPE_TARGET_TYPE (ftype);
3403 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3404 atype = TYPE_TARGET_TYPE (atype);
3405
d2e4a39e 3406 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3407 {
3408 default:
5b3d5b7d 3409 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3410 case TYPE_CODE_PTR:
3411 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3412 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3413 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3414 else
1265e4aa
JB
3415 return (may_deref
3416 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3417 case TYPE_CODE_INT:
3418 case TYPE_CODE_ENUM:
3419 case TYPE_CODE_RANGE:
3420 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3421 {
3422 case TYPE_CODE_INT:
3423 case TYPE_CODE_ENUM:
3424 case TYPE_CODE_RANGE:
3425 return 1;
3426 default:
3427 return 0;
3428 }
14f9c5c9
AS
3429
3430 case TYPE_CODE_ARRAY:
d2e4a39e 3431 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3432 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3433
3434 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3435 if (ada_is_array_descriptor_type (ftype))
3436 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3437 || ada_is_array_descriptor_type (atype));
14f9c5c9 3438 else
4c4b4cd2
PH
3439 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3440 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3441
3442 case TYPE_CODE_UNION:
3443 case TYPE_CODE_FLT:
3444 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3445 }
3446}
3447
3448/* Return non-zero if the formals of FUNC "sufficiently match" the
3449 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3450 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3451 argument function. */
14f9c5c9
AS
3452
3453static int
d2e4a39e 3454ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3455{
3456 int i;
d2e4a39e 3457 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3458
1265e4aa
JB
3459 if (SYMBOL_CLASS (func) == LOC_CONST
3460 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3461 return (n_actuals == 0);
3462 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3463 return 0;
3464
3465 if (TYPE_NFIELDS (func_type) != n_actuals)
3466 return 0;
3467
3468 for (i = 0; i < n_actuals; i += 1)
3469 {
4c4b4cd2 3470 if (actuals[i] == NULL)
76a01679
JB
3471 return 0;
3472 else
3473 {
5b4ee69b
MS
3474 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3475 i));
df407dfe 3476 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3477
76a01679
JB
3478 if (!ada_type_match (ftype, atype, 1))
3479 return 0;
3480 }
14f9c5c9
AS
3481 }
3482 return 1;
3483}
3484
3485/* False iff function type FUNC_TYPE definitely does not produce a value
3486 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3487 FUNC_TYPE is not a valid function type with a non-null return type
3488 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3489
3490static int
d2e4a39e 3491return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3492{
d2e4a39e 3493 struct type *return_type;
14f9c5c9
AS
3494
3495 if (func_type == NULL)
3496 return 1;
3497
4c4b4cd2 3498 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3499 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3500 else
18af8284 3501 return_type = get_base_type (func_type);
14f9c5c9
AS
3502 if (return_type == NULL)
3503 return 1;
3504
18af8284 3505 context_type = get_base_type (context_type);
14f9c5c9
AS
3506
3507 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3508 return context_type == NULL || return_type == context_type;
3509 else if (context_type == NULL)
3510 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3511 else
3512 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3513}
3514
3515
4c4b4cd2 3516/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3517 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3518 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3519 that returns that type, then eliminate matches that don't. If
3520 CONTEXT_TYPE is void and there is at least one match that does not
3521 return void, eliminate all matches that do.
3522
14f9c5c9
AS
3523 Asks the user if there is more than one match remaining. Returns -1
3524 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3525 solely for messages. May re-arrange and modify SYMS in
3526 the process; the index returned is for the modified vector. */
14f9c5c9 3527
4c4b4cd2
PH
3528static int
3529ada_resolve_function (struct ada_symbol_info syms[],
3530 int nsyms, struct value **args, int nargs,
3531 const char *name, struct type *context_type)
14f9c5c9 3532{
30b15541 3533 int fallback;
14f9c5c9 3534 int k;
4c4b4cd2 3535 int m; /* Number of hits */
14f9c5c9 3536
d2e4a39e 3537 m = 0;
30b15541
UW
3538 /* In the first pass of the loop, we only accept functions matching
3539 context_type. If none are found, we add a second pass of the loop
3540 where every function is accepted. */
3541 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3542 {
3543 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3544 {
61ee279c 3545 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
4c4b4cd2
PH
3546
3547 if (ada_args_match (syms[k].sym, args, nargs)
30b15541 3548 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3549 {
3550 syms[m] = syms[k];
3551 m += 1;
3552 }
3553 }
14f9c5c9
AS
3554 }
3555
3556 if (m == 0)
3557 return -1;
3558 else if (m > 1)
3559 {
323e0a4a 3560 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3561 user_select_syms (syms, m, 1);
14f9c5c9
AS
3562 return 0;
3563 }
3564 return 0;
3565}
3566
4c4b4cd2
PH
3567/* Returns true (non-zero) iff decoded name N0 should appear before N1
3568 in a listing of choices during disambiguation (see sort_choices, below).
3569 The idea is that overloadings of a subprogram name from the
3570 same package should sort in their source order. We settle for ordering
3571 such symbols by their trailing number (__N or $N). */
3572
14f9c5c9 3573static int
0d5cff50 3574encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3575{
3576 if (N1 == NULL)
3577 return 0;
3578 else if (N0 == NULL)
3579 return 1;
3580 else
3581 {
3582 int k0, k1;
5b4ee69b 3583
d2e4a39e 3584 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3585 ;
d2e4a39e 3586 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3587 ;
d2e4a39e 3588 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3589 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3590 {
3591 int n0, n1;
5b4ee69b 3592
4c4b4cd2
PH
3593 n0 = k0;
3594 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3595 n0 -= 1;
3596 n1 = k1;
3597 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3598 n1 -= 1;
3599 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3600 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3601 }
14f9c5c9
AS
3602 return (strcmp (N0, N1) < 0);
3603 }
3604}
d2e4a39e 3605
4c4b4cd2
PH
3606/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3607 encoded names. */
3608
d2e4a39e 3609static void
4c4b4cd2 3610sort_choices (struct ada_symbol_info syms[], int nsyms)
14f9c5c9 3611{
4c4b4cd2 3612 int i;
5b4ee69b 3613
d2e4a39e 3614 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3615 {
4c4b4cd2 3616 struct ada_symbol_info sym = syms[i];
14f9c5c9
AS
3617 int j;
3618
d2e4a39e 3619 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2
PH
3620 {
3621 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3622 SYMBOL_LINKAGE_NAME (sym.sym)))
3623 break;
3624 syms[j + 1] = syms[j];
3625 }
d2e4a39e 3626 syms[j + 1] = sym;
14f9c5c9
AS
3627 }
3628}
3629
4c4b4cd2
PH
3630/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3631 by asking the user (if necessary), returning the number selected,
3632 and setting the first elements of SYMS items. Error if no symbols
3633 selected. */
14f9c5c9
AS
3634
3635/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3636 to be re-integrated one of these days. */
14f9c5c9
AS
3637
3638int
4c4b4cd2 3639user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
14f9c5c9
AS
3640{
3641 int i;
d2e4a39e 3642 int *chosen = (int *) alloca (sizeof (int) * nsyms);
14f9c5c9
AS
3643 int n_chosen;
3644 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3645 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3646
3647 if (max_results < 1)
323e0a4a 3648 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3649 if (nsyms <= 1)
3650 return nsyms;
3651
717d2f5a
JB
3652 if (select_mode == multiple_symbols_cancel)
3653 error (_("\
3654canceled because the command is ambiguous\n\
3655See set/show multiple-symbol."));
3656
3657 /* If select_mode is "all", then return all possible symbols.
3658 Only do that if more than one symbol can be selected, of course.
3659 Otherwise, display the menu as usual. */
3660 if (select_mode == multiple_symbols_all && max_results > 1)
3661 return nsyms;
3662
323e0a4a 3663 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3664 if (max_results > 1)
323e0a4a 3665 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3666
4c4b4cd2 3667 sort_choices (syms, nsyms);
14f9c5c9
AS
3668
3669 for (i = 0; i < nsyms; i += 1)
3670 {
4c4b4cd2
PH
3671 if (syms[i].sym == NULL)
3672 continue;
3673
3674 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3675 {
76a01679
JB
3676 struct symtab_and_line sal =
3677 find_function_start_sal (syms[i].sym, 1);
5b4ee69b 3678
323e0a4a
AC
3679 if (sal.symtab == NULL)
3680 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3681 i + first_choice,
3682 SYMBOL_PRINT_NAME (syms[i].sym),
3683 sal.line);
3684 else
3685 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3686 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821
JK
3687 symtab_to_filename_for_display (sal.symtab),
3688 sal.line);
4c4b4cd2
PH
3689 continue;
3690 }
d2e4a39e 3691 else
4c4b4cd2
PH
3692 {
3693 int is_enumeral =
3694 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3695 && SYMBOL_TYPE (syms[i].sym) != NULL
3696 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
210bbc17 3697 struct symtab *symtab = SYMBOL_SYMTAB (syms[i].sym);
4c4b4cd2
PH
3698
3699 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
323e0a4a 3700 printf_unfiltered (_("[%d] %s at %s:%d\n"),
4c4b4cd2
PH
3701 i + first_choice,
3702 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821
JK
3703 symtab_to_filename_for_display (symtab),
3704 SYMBOL_LINE (syms[i].sym));
76a01679
JB
3705 else if (is_enumeral
3706 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
4c4b4cd2 3707 {
a3f17187 3708 printf_unfiltered (("[%d] "), i + first_choice);
76a01679 3709 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
79d43c61 3710 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3711 printf_unfiltered (_("'(%s) (enumeral)\n"),
4c4b4cd2
PH
3712 SYMBOL_PRINT_NAME (syms[i].sym));
3713 }
3714 else if (symtab != NULL)
3715 printf_unfiltered (is_enumeral
323e0a4a
AC
3716 ? _("[%d] %s in %s (enumeral)\n")
3717 : _("[%d] %s at %s:?\n"),
4c4b4cd2
PH
3718 i + first_choice,
3719 SYMBOL_PRINT_NAME (syms[i].sym),
05cba821 3720 symtab_to_filename_for_display (symtab));
4c4b4cd2
PH
3721 else
3722 printf_unfiltered (is_enumeral
323e0a4a
AC
3723 ? _("[%d] %s (enumeral)\n")
3724 : _("[%d] %s at ?\n"),
4c4b4cd2
PH
3725 i + first_choice,
3726 SYMBOL_PRINT_NAME (syms[i].sym));
3727 }
14f9c5c9 3728 }
d2e4a39e 3729
14f9c5c9 3730 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 3731 "overload-choice");
14f9c5c9
AS
3732
3733 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 3734 syms[i] = syms[chosen[i]];
14f9c5c9
AS
3735
3736 return n_chosen;
3737}
3738
3739/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 3740 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
3741 order in CHOICES[0 .. N-1], and return N.
3742
3743 The user types choices as a sequence of numbers on one line
3744 separated by blanks, encoding them as follows:
3745
4c4b4cd2 3746 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
3747 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3748 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3749
4c4b4cd2 3750 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
3751
3752 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 3753 prompts (for use with the -f switch). */
14f9c5c9
AS
3754
3755int
d2e4a39e 3756get_selections (int *choices, int n_choices, int max_results,
4c4b4cd2 3757 int is_all_choice, char *annotation_suffix)
14f9c5c9 3758{
d2e4a39e 3759 char *args;
0bcd0149 3760 char *prompt;
14f9c5c9
AS
3761 int n_chosen;
3762 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 3763
14f9c5c9
AS
3764 prompt = getenv ("PS2");
3765 if (prompt == NULL)
0bcd0149 3766 prompt = "> ";
14f9c5c9 3767
0bcd0149 3768 args = command_line_input (prompt, 0, annotation_suffix);
d2e4a39e 3769
14f9c5c9 3770 if (args == NULL)
323e0a4a 3771 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
3772
3773 n_chosen = 0;
76a01679 3774
4c4b4cd2
PH
3775 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3776 order, as given in args. Choices are validated. */
14f9c5c9
AS
3777 while (1)
3778 {
d2e4a39e 3779 char *args2;
14f9c5c9
AS
3780 int choice, j;
3781
0fcd72ba 3782 args = skip_spaces (args);
14f9c5c9 3783 if (*args == '\0' && n_chosen == 0)
323e0a4a 3784 error_no_arg (_("one or more choice numbers"));
14f9c5c9 3785 else if (*args == '\0')
4c4b4cd2 3786 break;
14f9c5c9
AS
3787
3788 choice = strtol (args, &args2, 10);
d2e4a39e 3789 if (args == args2 || choice < 0
4c4b4cd2 3790 || choice > n_choices + first_choice - 1)
323e0a4a 3791 error (_("Argument must be choice number"));
14f9c5c9
AS
3792 args = args2;
3793
d2e4a39e 3794 if (choice == 0)
323e0a4a 3795 error (_("cancelled"));
14f9c5c9
AS
3796
3797 if (choice < first_choice)
4c4b4cd2
PH
3798 {
3799 n_chosen = n_choices;
3800 for (j = 0; j < n_choices; j += 1)
3801 choices[j] = j;
3802 break;
3803 }
14f9c5c9
AS
3804 choice -= first_choice;
3805
d2e4a39e 3806 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
3807 {
3808 }
14f9c5c9
AS
3809
3810 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
3811 {
3812 int k;
5b4ee69b 3813
4c4b4cd2
PH
3814 for (k = n_chosen - 1; k > j; k -= 1)
3815 choices[k + 1] = choices[k];
3816 choices[j + 1] = choice;
3817 n_chosen += 1;
3818 }
14f9c5c9
AS
3819 }
3820
3821 if (n_chosen > max_results)
323e0a4a 3822 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 3823
14f9c5c9
AS
3824 return n_chosen;
3825}
3826
4c4b4cd2
PH
3827/* Replace the operator of length OPLEN at position PC in *EXPP with a call
3828 on the function identified by SYM and BLOCK, and taking NARGS
3829 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
3830
3831static void
d2e4a39e 3832replace_operator_with_call (struct expression **expp, int pc, int nargs,
4c4b4cd2 3833 int oplen, struct symbol *sym,
270140bd 3834 const struct block *block)
14f9c5c9
AS
3835{
3836 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 3837 symbol, -oplen for operator being replaced). */
d2e4a39e 3838 struct expression *newexp = (struct expression *)
8c1a34e7 3839 xzalloc (sizeof (struct expression)
4c4b4cd2 3840 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
d2e4a39e 3841 struct expression *exp = *expp;
14f9c5c9
AS
3842
3843 newexp->nelts = exp->nelts + 7 - oplen;
3844 newexp->language_defn = exp->language_defn;
3489610d 3845 newexp->gdbarch = exp->gdbarch;
14f9c5c9 3846 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 3847 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 3848 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
3849
3850 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3851 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3852
3853 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3854 newexp->elts[pc + 4].block = block;
3855 newexp->elts[pc + 5].symbol = sym;
3856
3857 *expp = newexp;
aacb1f0a 3858 xfree (exp);
d2e4a39e 3859}
14f9c5c9
AS
3860
3861/* Type-class predicates */
3862
4c4b4cd2
PH
3863/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3864 or FLOAT). */
14f9c5c9
AS
3865
3866static int
d2e4a39e 3867numeric_type_p (struct type *type)
14f9c5c9
AS
3868{
3869 if (type == NULL)
3870 return 0;
d2e4a39e
AS
3871 else
3872 {
3873 switch (TYPE_CODE (type))
4c4b4cd2
PH
3874 {
3875 case TYPE_CODE_INT:
3876 case TYPE_CODE_FLT:
3877 return 1;
3878 case TYPE_CODE_RANGE:
3879 return (type == TYPE_TARGET_TYPE (type)
3880 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3881 default:
3882 return 0;
3883 }
d2e4a39e 3884 }
14f9c5c9
AS
3885}
3886
4c4b4cd2 3887/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
3888
3889static int
d2e4a39e 3890integer_type_p (struct type *type)
14f9c5c9
AS
3891{
3892 if (type == NULL)
3893 return 0;
d2e4a39e
AS
3894 else
3895 {
3896 switch (TYPE_CODE (type))
4c4b4cd2
PH
3897 {
3898 case TYPE_CODE_INT:
3899 return 1;
3900 case TYPE_CODE_RANGE:
3901 return (type == TYPE_TARGET_TYPE (type)
3902 || integer_type_p (TYPE_TARGET_TYPE (type)));
3903 default:
3904 return 0;
3905 }
d2e4a39e 3906 }
14f9c5c9
AS
3907}
3908
4c4b4cd2 3909/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
3910
3911static int
d2e4a39e 3912scalar_type_p (struct type *type)
14f9c5c9
AS
3913{
3914 if (type == NULL)
3915 return 0;
d2e4a39e
AS
3916 else
3917 {
3918 switch (TYPE_CODE (type))
4c4b4cd2
PH
3919 {
3920 case TYPE_CODE_INT:
3921 case TYPE_CODE_RANGE:
3922 case TYPE_CODE_ENUM:
3923 case TYPE_CODE_FLT:
3924 return 1;
3925 default:
3926 return 0;
3927 }
d2e4a39e 3928 }
14f9c5c9
AS
3929}
3930
4c4b4cd2 3931/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
3932
3933static int
d2e4a39e 3934discrete_type_p (struct type *type)
14f9c5c9
AS
3935{
3936 if (type == NULL)
3937 return 0;
d2e4a39e
AS
3938 else
3939 {
3940 switch (TYPE_CODE (type))
4c4b4cd2
PH
3941 {
3942 case TYPE_CODE_INT:
3943 case TYPE_CODE_RANGE:
3944 case TYPE_CODE_ENUM:
872f0337 3945 case TYPE_CODE_BOOL:
4c4b4cd2
PH
3946 return 1;
3947 default:
3948 return 0;
3949 }
d2e4a39e 3950 }
14f9c5c9
AS
3951}
3952
4c4b4cd2
PH
3953/* Returns non-zero if OP with operands in the vector ARGS could be
3954 a user-defined function. Errs on the side of pre-defined operators
3955 (i.e., result 0). */
14f9c5c9
AS
3956
3957static int
d2e4a39e 3958possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 3959{
76a01679 3960 struct type *type0 =
df407dfe 3961 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 3962 struct type *type1 =
df407dfe 3963 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 3964
4c4b4cd2
PH
3965 if (type0 == NULL)
3966 return 0;
3967
14f9c5c9
AS
3968 switch (op)
3969 {
3970 default:
3971 return 0;
3972
3973 case BINOP_ADD:
3974 case BINOP_SUB:
3975 case BINOP_MUL:
3976 case BINOP_DIV:
d2e4a39e 3977 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
3978
3979 case BINOP_REM:
3980 case BINOP_MOD:
3981 case BINOP_BITWISE_AND:
3982 case BINOP_BITWISE_IOR:
3983 case BINOP_BITWISE_XOR:
d2e4a39e 3984 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3985
3986 case BINOP_EQUAL:
3987 case BINOP_NOTEQUAL:
3988 case BINOP_LESS:
3989 case BINOP_GTR:
3990 case BINOP_LEQ:
3991 case BINOP_GEQ:
d2e4a39e 3992 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
3993
3994 case BINOP_CONCAT:
ee90b9ab 3995 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
3996
3997 case BINOP_EXP:
d2e4a39e 3998 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3999
4000 case UNOP_NEG:
4001 case UNOP_PLUS:
4002 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
4003 case UNOP_ABS:
4004 return (!numeric_type_p (type0));
14f9c5c9
AS
4005
4006 }
4007}
4008\f
4c4b4cd2 4009 /* Renaming */
14f9c5c9 4010
aeb5907d
JB
4011/* NOTES:
4012
4013 1. In the following, we assume that a renaming type's name may
4014 have an ___XD suffix. It would be nice if this went away at some
4015 point.
4016 2. We handle both the (old) purely type-based representation of
4017 renamings and the (new) variable-based encoding. At some point,
4018 it is devoutly to be hoped that the former goes away
4019 (FIXME: hilfinger-2007-07-09).
4020 3. Subprogram renamings are not implemented, although the XRS
4021 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4022
4023/* If SYM encodes a renaming,
4024
4025 <renaming> renames <renamed entity>,
4026
4027 sets *LEN to the length of the renamed entity's name,
4028 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4029 the string describing the subcomponent selected from the renamed
0963b4bd 4030 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
4031 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4032 are undefined). Otherwise, returns a value indicating the category
4033 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4034 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4035 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4036 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4037 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4038 may be NULL, in which case they are not assigned.
4039
4040 [Currently, however, GCC does not generate subprogram renamings.] */
4041
4042enum ada_renaming_category
4043ada_parse_renaming (struct symbol *sym,
4044 const char **renamed_entity, int *len,
4045 const char **renaming_expr)
4046{
4047 enum ada_renaming_category kind;
4048 const char *info;
4049 const char *suffix;
4050
4051 if (sym == NULL)
4052 return ADA_NOT_RENAMING;
4053 switch (SYMBOL_CLASS (sym))
14f9c5c9 4054 {
aeb5907d
JB
4055 default:
4056 return ADA_NOT_RENAMING;
4057 case LOC_TYPEDEF:
4058 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4059 renamed_entity, len, renaming_expr);
4060 case LOC_LOCAL:
4061 case LOC_STATIC:
4062 case LOC_COMPUTED:
4063 case LOC_OPTIMIZED_OUT:
4064 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4065 if (info == NULL)
4066 return ADA_NOT_RENAMING;
4067 switch (info[5])
4068 {
4069 case '_':
4070 kind = ADA_OBJECT_RENAMING;
4071 info += 6;
4072 break;
4073 case 'E':
4074 kind = ADA_EXCEPTION_RENAMING;
4075 info += 7;
4076 break;
4077 case 'P':
4078 kind = ADA_PACKAGE_RENAMING;
4079 info += 7;
4080 break;
4081 case 'S':
4082 kind = ADA_SUBPROGRAM_RENAMING;
4083 info += 7;
4084 break;
4085 default:
4086 return ADA_NOT_RENAMING;
4087 }
14f9c5c9 4088 }
4c4b4cd2 4089
aeb5907d
JB
4090 if (renamed_entity != NULL)
4091 *renamed_entity = info;
4092 suffix = strstr (info, "___XE");
4093 if (suffix == NULL || suffix == info)
4094 return ADA_NOT_RENAMING;
4095 if (len != NULL)
4096 *len = strlen (info) - strlen (suffix);
4097 suffix += 5;
4098 if (renaming_expr != NULL)
4099 *renaming_expr = suffix;
4100 return kind;
4101}
4102
4103/* Assuming TYPE encodes a renaming according to the old encoding in
4104 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4105 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4106 ADA_NOT_RENAMING otherwise. */
4107static enum ada_renaming_category
4108parse_old_style_renaming (struct type *type,
4109 const char **renamed_entity, int *len,
4110 const char **renaming_expr)
4111{
4112 enum ada_renaming_category kind;
4113 const char *name;
4114 const char *info;
4115 const char *suffix;
14f9c5c9 4116
aeb5907d
JB
4117 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4118 || TYPE_NFIELDS (type) != 1)
4119 return ADA_NOT_RENAMING;
14f9c5c9 4120
aeb5907d
JB
4121 name = type_name_no_tag (type);
4122 if (name == NULL)
4123 return ADA_NOT_RENAMING;
4124
4125 name = strstr (name, "___XR");
4126 if (name == NULL)
4127 return ADA_NOT_RENAMING;
4128 switch (name[5])
4129 {
4130 case '\0':
4131 case '_':
4132 kind = ADA_OBJECT_RENAMING;
4133 break;
4134 case 'E':
4135 kind = ADA_EXCEPTION_RENAMING;
4136 break;
4137 case 'P':
4138 kind = ADA_PACKAGE_RENAMING;
4139 break;
4140 case 'S':
4141 kind = ADA_SUBPROGRAM_RENAMING;
4142 break;
4143 default:
4144 return ADA_NOT_RENAMING;
4145 }
14f9c5c9 4146
aeb5907d
JB
4147 info = TYPE_FIELD_NAME (type, 0);
4148 if (info == NULL)
4149 return ADA_NOT_RENAMING;
4150 if (renamed_entity != NULL)
4151 *renamed_entity = info;
4152 suffix = strstr (info, "___XE");
4153 if (renaming_expr != NULL)
4154 *renaming_expr = suffix + 5;
4155 if (suffix == NULL || suffix == info)
4156 return ADA_NOT_RENAMING;
4157 if (len != NULL)
4158 *len = suffix - info;
4159 return kind;
a5ee536b
JB
4160}
4161
4162/* Compute the value of the given RENAMING_SYM, which is expected to
4163 be a symbol encoding a renaming expression. BLOCK is the block
4164 used to evaluate the renaming. */
52ce6436 4165
a5ee536b
JB
4166static struct value *
4167ada_read_renaming_var_value (struct symbol *renaming_sym,
4168 struct block *block)
4169{
bbc13ae3 4170 const char *sym_name;
a5ee536b
JB
4171 struct expression *expr;
4172 struct value *value;
4173 struct cleanup *old_chain = NULL;
4174
bbc13ae3 4175 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
1bb9788d 4176 expr = parse_exp_1 (&sym_name, 0, block, 0);
bbc13ae3 4177 old_chain = make_cleanup (free_current_contents, &expr);
a5ee536b
JB
4178 value = evaluate_expression (expr);
4179
4180 do_cleanups (old_chain);
4181 return value;
4182}
14f9c5c9 4183\f
d2e4a39e 4184
4c4b4cd2 4185 /* Evaluation: Function Calls */
14f9c5c9 4186
4c4b4cd2 4187/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4188 lvalues, and otherwise has the side-effect of allocating memory
4189 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4190
d2e4a39e 4191static struct value *
40bc484c 4192ensure_lval (struct value *val)
14f9c5c9 4193{
40bc484c
JB
4194 if (VALUE_LVAL (val) == not_lval
4195 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4196 {
df407dfe 4197 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4198 const CORE_ADDR addr =
4199 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4200
40bc484c 4201 set_value_address (val, addr);
a84a8a0d 4202 VALUE_LVAL (val) = lval_memory;
40bc484c 4203 write_memory (addr, value_contents (val), len);
c3e5cd34 4204 }
14f9c5c9
AS
4205
4206 return val;
4207}
4208
4209/* Return the value ACTUAL, converted to be an appropriate value for a
4210 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4211 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4212 values not residing in memory, updating it as needed. */
14f9c5c9 4213
a93c0eb6 4214struct value *
40bc484c 4215ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4216{
df407dfe 4217 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4218 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4219 struct type *formal_target =
4220 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4221 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4222 struct type *actual_target =
4223 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4224 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4225
4c4b4cd2 4226 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4227 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4228 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4229 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4230 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4231 {
a84a8a0d 4232 struct value *result;
5b4ee69b 4233
14f9c5c9 4234 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4235 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4236 result = desc_data (actual);
14f9c5c9 4237 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4238 {
4239 if (VALUE_LVAL (actual) != lval_memory)
4240 {
4241 struct value *val;
5b4ee69b 4242
df407dfe 4243 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4244 val = allocate_value (actual_type);
990a07ab 4245 memcpy ((char *) value_contents_raw (val),
0fd88904 4246 (char *) value_contents (actual),
4c4b4cd2 4247 TYPE_LENGTH (actual_type));
40bc484c 4248 actual = ensure_lval (val);
4c4b4cd2 4249 }
a84a8a0d 4250 result = value_addr (actual);
4c4b4cd2 4251 }
a84a8a0d
JB
4252 else
4253 return actual;
b1af9e97 4254 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4255 }
4256 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4257 return ada_value_ind (actual);
4258
4259 return actual;
4260}
4261
438c98a1
JB
4262/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4263 type TYPE. This is usually an inefficient no-op except on some targets
4264 (such as AVR) where the representation of a pointer and an address
4265 differs. */
4266
4267static CORE_ADDR
4268value_pointer (struct value *value, struct type *type)
4269{
4270 struct gdbarch *gdbarch = get_type_arch (type);
4271 unsigned len = TYPE_LENGTH (type);
4272 gdb_byte *buf = alloca (len);
4273 CORE_ADDR addr;
4274
4275 addr = value_address (value);
4276 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4277 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4278 return addr;
4279}
4280
14f9c5c9 4281
4c4b4cd2
PH
4282/* Push a descriptor of type TYPE for array value ARR on the stack at
4283 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4284 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4285 to-descriptor type rather than a descriptor type), a struct value *
4286 representing a pointer to this descriptor. */
14f9c5c9 4287
d2e4a39e 4288static struct value *
40bc484c 4289make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4290{
d2e4a39e
AS
4291 struct type *bounds_type = desc_bounds_type (type);
4292 struct type *desc_type = desc_base_type (type);
4293 struct value *descriptor = allocate_value (desc_type);
4294 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4295 int i;
d2e4a39e 4296
0963b4bd
MS
4297 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4298 i > 0; i -= 1)
14f9c5c9 4299 {
19f220c3
JK
4300 modify_field (value_type (bounds), value_contents_writeable (bounds),
4301 ada_array_bound (arr, i, 0),
4302 desc_bound_bitpos (bounds_type, i, 0),
4303 desc_bound_bitsize (bounds_type, i, 0));
4304 modify_field (value_type (bounds), value_contents_writeable (bounds),
4305 ada_array_bound (arr, i, 1),
4306 desc_bound_bitpos (bounds_type, i, 1),
4307 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4308 }
d2e4a39e 4309
40bc484c 4310 bounds = ensure_lval (bounds);
d2e4a39e 4311
19f220c3
JK
4312 modify_field (value_type (descriptor),
4313 value_contents_writeable (descriptor),
4314 value_pointer (ensure_lval (arr),
4315 TYPE_FIELD_TYPE (desc_type, 0)),
4316 fat_pntr_data_bitpos (desc_type),
4317 fat_pntr_data_bitsize (desc_type));
4318
4319 modify_field (value_type (descriptor),
4320 value_contents_writeable (descriptor),
4321 value_pointer (bounds,
4322 TYPE_FIELD_TYPE (desc_type, 1)),
4323 fat_pntr_bounds_bitpos (desc_type),
4324 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4325
40bc484c 4326 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4327
4328 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4329 return value_addr (descriptor);
4330 else
4331 return descriptor;
4332}
14f9c5c9 4333\f
3d9434b5
JB
4334 /* Symbol Cache Module */
4335
3d9434b5 4336/* Performance measurements made as of 2010-01-15 indicate that
ee01b665 4337 this cache does bring some noticeable improvements. Depending
3d9434b5
JB
4338 on the type of entity being printed, the cache can make it as much
4339 as an order of magnitude faster than without it.
4340
4341 The descriptive type DWARF extension has significantly reduced
4342 the need for this cache, at least when DWARF is being used. However,
4343 even in this case, some expensive name-based symbol searches are still
4344 sometimes necessary - to find an XVZ variable, mostly. */
4345
ee01b665 4346/* Initialize the contents of SYM_CACHE. */
3d9434b5 4347
ee01b665
JB
4348static void
4349ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4350{
4351 obstack_init (&sym_cache->cache_space);
4352 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4353}
3d9434b5 4354
ee01b665
JB
4355/* Free the memory used by SYM_CACHE. */
4356
4357static void
4358ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
3d9434b5 4359{
ee01b665
JB
4360 obstack_free (&sym_cache->cache_space, NULL);
4361 xfree (sym_cache);
4362}
3d9434b5 4363
ee01b665
JB
4364/* Return the symbol cache associated to the given program space PSPACE.
4365 If not allocated for this PSPACE yet, allocate and initialize one. */
3d9434b5 4366
ee01b665
JB
4367static struct ada_symbol_cache *
4368ada_get_symbol_cache (struct program_space *pspace)
4369{
4370 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4371 struct ada_symbol_cache *sym_cache = pspace_data->sym_cache;
4372
4373 if (sym_cache == NULL)
4374 {
4375 sym_cache = XCNEW (struct ada_symbol_cache);
4376 ada_init_symbol_cache (sym_cache);
4377 }
4378
4379 return sym_cache;
4380}
3d9434b5
JB
4381
4382/* Clear all entries from the symbol cache. */
4383
4384static void
4385ada_clear_symbol_cache (void)
4386{
ee01b665
JB
4387 struct ada_symbol_cache *sym_cache
4388 = ada_get_symbol_cache (current_program_space);
4389
4390 obstack_free (&sym_cache->cache_space, NULL);
4391 ada_init_symbol_cache (sym_cache);
3d9434b5
JB
4392}
4393
b50c8614
KS
4394/* STRUCT_DOMAIN symbols are also typedefs for the type. This function tests
4395 the equivalency of two Ada symbol domain types. */
4396
4397static int
4398ada_symbol_matches_domain (domain_enum symbol_domain, domain_enum domain)
4399{
4400 if (symbol_domain == domain
4401 || ((domain == VAR_DOMAIN || domain == STRUCT_DOMAIN)
4402 && symbol_domain == STRUCT_DOMAIN))
4403 return 1;
4404
4405 return 0;
4406}
4407
3d9434b5
JB
4408/* Search our cache for an entry matching NAME and NAMESPACE.
4409 Return it if found, or NULL otherwise. */
4410
4411static struct cache_entry **
4412find_entry (const char *name, domain_enum namespace)
4413{
ee01b665
JB
4414 struct ada_symbol_cache *sym_cache
4415 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4416 int h = msymbol_hash (name) % HASH_SIZE;
4417 struct cache_entry **e;
4418
ee01b665 4419 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
3d9434b5
JB
4420 {
4421 if (namespace == (*e)->namespace && strcmp (name, (*e)->name) == 0)
4422 return e;
4423 }
4424 return NULL;
4425}
4426
4427/* Search the symbol cache for an entry matching NAME and NAMESPACE.
4428 Return 1 if found, 0 otherwise.
4429
4430 If an entry was found and SYM is not NULL, set *SYM to the entry's
4431 SYM. Same principle for BLOCK if not NULL. */
96d887e8 4432
96d887e8
PH
4433static int
4434lookup_cached_symbol (const char *name, domain_enum namespace,
f0c5f9b2 4435 struct symbol **sym, const struct block **block)
96d887e8 4436{
3d9434b5
JB
4437 struct cache_entry **e = find_entry (name, namespace);
4438
4439 if (e == NULL)
4440 return 0;
4441 if (sym != NULL)
4442 *sym = (*e)->sym;
4443 if (block != NULL)
4444 *block = (*e)->block;
4445 return 1;
96d887e8
PH
4446}
4447
3d9434b5
JB
4448/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4449 in domain NAMESPACE, save this result in our symbol cache. */
4450
96d887e8
PH
4451static void
4452cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
270140bd 4453 const struct block *block)
96d887e8 4454{
ee01b665
JB
4455 struct ada_symbol_cache *sym_cache
4456 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4457 int h;
4458 char *copy;
4459 struct cache_entry *e;
4460
4461 /* If the symbol is a local symbol, then do not cache it, as a search
4462 for that symbol depends on the context. To determine whether
4463 the symbol is local or not, we check the block where we found it
4464 against the global and static blocks of its associated symtab. */
4465 if (sym
4466 && BLOCKVECTOR_BLOCK (BLOCKVECTOR (sym->symtab), GLOBAL_BLOCK) != block
4467 && BLOCKVECTOR_BLOCK (BLOCKVECTOR (sym->symtab), STATIC_BLOCK) != block)
4468 return;
4469
4470 h = msymbol_hash (name) % HASH_SIZE;
ee01b665
JB
4471 e = (struct cache_entry *) obstack_alloc (&sym_cache->cache_space,
4472 sizeof (*e));
4473 e->next = sym_cache->root[h];
4474 sym_cache->root[h] = e;
4475 e->name = copy = obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
3d9434b5
JB
4476 strcpy (copy, name);
4477 e->sym = sym;
4478 e->namespace = namespace;
4479 e->block = block;
96d887e8 4480}
4c4b4cd2
PH
4481\f
4482 /* Symbol Lookup */
4483
c0431670
JB
4484/* Return nonzero if wild matching should be used when searching for
4485 all symbols matching LOOKUP_NAME.
4486
4487 LOOKUP_NAME is expected to be a symbol name after transformation
4488 for Ada lookups (see ada_name_for_lookup). */
4489
4490static int
4491should_use_wild_match (const char *lookup_name)
4492{
4493 return (strstr (lookup_name, "__") == NULL);
4494}
4495
4c4b4cd2
PH
4496/* Return the result of a standard (literal, C-like) lookup of NAME in
4497 given DOMAIN, visible from lexical block BLOCK. */
4498
4499static struct symbol *
4500standard_lookup (const char *name, const struct block *block,
4501 domain_enum domain)
4502{
acbd605d
MGD
4503 /* Initialize it just to avoid a GCC false warning. */
4504 struct symbol *sym = NULL;
4c4b4cd2 4505
2570f2b7 4506 if (lookup_cached_symbol (name, domain, &sym, NULL))
4c4b4cd2 4507 return sym;
2570f2b7 4508 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
b50c8614
KS
4509
4510 /* STRUCT_DOMAIN symbols also define a typedef for the type. Lookup
4511 a STRUCT_DOMAIN symbol if one is requested for VAR_DOMAIN and not
4512 found. */
4513 if (sym == NULL && domain == VAR_DOMAIN)
4514 sym = lookup_symbol_in_language (name, block, STRUCT_DOMAIN, language_c, 0);
4515
2570f2b7 4516 cache_symbol (name, domain, sym, block_found);
4c4b4cd2
PH
4517 return sym;
4518}
4519
4520
4521/* Non-zero iff there is at least one non-function/non-enumeral symbol
4522 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4523 since they contend in overloading in the same way. */
4524static int
4525is_nonfunction (struct ada_symbol_info syms[], int n)
4526{
4527 int i;
4528
4529 for (i = 0; i < n; i += 1)
4530 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
4531 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
4532 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
14f9c5c9
AS
4533 return 1;
4534
4535 return 0;
4536}
4537
4538/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4539 struct types. Otherwise, they may not. */
14f9c5c9
AS
4540
4541static int
d2e4a39e 4542equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4543{
d2e4a39e 4544 if (type0 == type1)
14f9c5c9 4545 return 1;
d2e4a39e 4546 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4547 || TYPE_CODE (type0) != TYPE_CODE (type1))
4548 return 0;
d2e4a39e 4549 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4550 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4551 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4552 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4553 return 1;
d2e4a39e 4554
14f9c5c9
AS
4555 return 0;
4556}
4557
4558/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4559 no more defined than that of SYM1. */
14f9c5c9
AS
4560
4561static int
d2e4a39e 4562lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4563{
4564 if (sym0 == sym1)
4565 return 1;
176620f1 4566 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4567 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4568 return 0;
4569
d2e4a39e 4570 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4571 {
4572 case LOC_UNDEF:
4573 return 1;
4574 case LOC_TYPEDEF:
4575 {
4c4b4cd2
PH
4576 struct type *type0 = SYMBOL_TYPE (sym0);
4577 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4578 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4579 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4580 int len0 = strlen (name0);
5b4ee69b 4581
4c4b4cd2
PH
4582 return
4583 TYPE_CODE (type0) == TYPE_CODE (type1)
4584 && (equiv_types (type0, type1)
4585 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4586 && strncmp (name1 + len0, "___XV", 5) == 0));
14f9c5c9
AS
4587 }
4588 case LOC_CONST:
4589 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4590 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4591 default:
4592 return 0;
14f9c5c9
AS
4593 }
4594}
4595
4c4b4cd2
PH
4596/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4597 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4598
4599static void
76a01679
JB
4600add_defn_to_vec (struct obstack *obstackp,
4601 struct symbol *sym,
f0c5f9b2 4602 const struct block *block)
14f9c5c9
AS
4603{
4604 int i;
4c4b4cd2 4605 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4606
529cad9c
PH
4607 /* Do not try to complete stub types, as the debugger is probably
4608 already scanning all symbols matching a certain name at the
4609 time when this function is called. Trying to replace the stub
4610 type by its associated full type will cause us to restart a scan
4611 which may lead to an infinite recursion. Instead, the client
4612 collecting the matching symbols will end up collecting several
4613 matches, with at least one of them complete. It can then filter
4614 out the stub ones if needed. */
4615
4c4b4cd2
PH
4616 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4617 {
4618 if (lesseq_defined_than (sym, prevDefns[i].sym))
4619 return;
4620 else if (lesseq_defined_than (prevDefns[i].sym, sym))
4621 {
4622 prevDefns[i].sym = sym;
4623 prevDefns[i].block = block;
4c4b4cd2 4624 return;
76a01679 4625 }
4c4b4cd2
PH
4626 }
4627
4628 {
4629 struct ada_symbol_info info;
4630
4631 info.sym = sym;
4632 info.block = block;
4c4b4cd2
PH
4633 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
4634 }
4635}
4636
4637/* Number of ada_symbol_info structures currently collected in
4638 current vector in *OBSTACKP. */
4639
76a01679
JB
4640static int
4641num_defns_collected (struct obstack *obstackp)
4c4b4cd2
PH
4642{
4643 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
4644}
4645
4646/* Vector of ada_symbol_info structures currently collected in current
4647 vector in *OBSTACKP. If FINISH, close off the vector and return
4648 its final address. */
4649
76a01679 4650static struct ada_symbol_info *
4c4b4cd2
PH
4651defns_collected (struct obstack *obstackp, int finish)
4652{
4653 if (finish)
4654 return obstack_finish (obstackp);
4655 else
4656 return (struct ada_symbol_info *) obstack_base (obstackp);
4657}
4658
7c7b6655
TT
4659/* Return a bound minimal symbol matching NAME according to Ada
4660 decoding rules. Returns an invalid symbol if there is no such
4661 minimal symbol. Names prefixed with "standard__" are handled
4662 specially: "standard__" is first stripped off, and only static and
4663 global symbols are searched. */
4c4b4cd2 4664
7c7b6655 4665struct bound_minimal_symbol
96d887e8 4666ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4667{
7c7b6655 4668 struct bound_minimal_symbol result;
4c4b4cd2 4669 struct objfile *objfile;
96d887e8 4670 struct minimal_symbol *msymbol;
dc4024cd 4671 const int wild_match_p = should_use_wild_match (name);
4c4b4cd2 4672
7c7b6655
TT
4673 memset (&result, 0, sizeof (result));
4674
c0431670
JB
4675 /* Special case: If the user specifies a symbol name inside package
4676 Standard, do a non-wild matching of the symbol name without
4677 the "standard__" prefix. This was primarily introduced in order
4678 to allow the user to specifically access the standard exceptions
4679 using, for instance, Standard.Constraint_Error when Constraint_Error
4680 is ambiguous (due to the user defining its own Constraint_Error
4681 entity inside its program). */
96d887e8 4682 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
c0431670 4683 name += sizeof ("standard__") - 1;
4c4b4cd2 4684
96d887e8
PH
4685 ALL_MSYMBOLS (objfile, msymbol)
4686 {
efd66ac6 4687 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), name, wild_match_p)
96d887e8 4688 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
7c7b6655
TT
4689 {
4690 result.minsym = msymbol;
4691 result.objfile = objfile;
4692 break;
4693 }
96d887e8 4694 }
4c4b4cd2 4695
7c7b6655 4696 return result;
96d887e8 4697}
4c4b4cd2 4698
96d887e8
PH
4699/* For all subprograms that statically enclose the subprogram of the
4700 selected frame, add symbols matching identifier NAME in DOMAIN
4701 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4702 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4703 with a wildcard prefix. */
4c4b4cd2 4704
96d887e8
PH
4705static void
4706add_symbols_from_enclosing_procs (struct obstack *obstackp,
76a01679 4707 const char *name, domain_enum namespace,
48b78332 4708 int wild_match_p)
96d887e8 4709{
96d887e8 4710}
14f9c5c9 4711
96d887e8
PH
4712/* True if TYPE is definitely an artificial type supplied to a symbol
4713 for which no debugging information was given in the symbol file. */
14f9c5c9 4714
96d887e8
PH
4715static int
4716is_nondebugging_type (struct type *type)
4717{
0d5cff50 4718 const char *name = ada_type_name (type);
5b4ee69b 4719
96d887e8
PH
4720 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4721}
4c4b4cd2 4722
8f17729f
JB
4723/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4724 that are deemed "identical" for practical purposes.
4725
4726 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4727 types and that their number of enumerals is identical (in other
4728 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4729
4730static int
4731ada_identical_enum_types_p (struct type *type1, struct type *type2)
4732{
4733 int i;
4734
4735 /* The heuristic we use here is fairly conservative. We consider
4736 that 2 enumerate types are identical if they have the same
4737 number of enumerals and that all enumerals have the same
4738 underlying value and name. */
4739
4740 /* All enums in the type should have an identical underlying value. */
4741 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 4742 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
4743 return 0;
4744
4745 /* All enumerals should also have the same name (modulo any numerical
4746 suffix). */
4747 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4748 {
0d5cff50
DE
4749 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4750 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
4751 int len_1 = strlen (name_1);
4752 int len_2 = strlen (name_2);
4753
4754 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4755 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4756 if (len_1 != len_2
4757 || strncmp (TYPE_FIELD_NAME (type1, i),
4758 TYPE_FIELD_NAME (type2, i),
4759 len_1) != 0)
4760 return 0;
4761 }
4762
4763 return 1;
4764}
4765
4766/* Return nonzero if all the symbols in SYMS are all enumeral symbols
4767 that are deemed "identical" for practical purposes. Sometimes,
4768 enumerals are not strictly identical, but their types are so similar
4769 that they can be considered identical.
4770
4771 For instance, consider the following code:
4772
4773 type Color is (Black, Red, Green, Blue, White);
4774 type RGB_Color is new Color range Red .. Blue;
4775
4776 Type RGB_Color is a subrange of an implicit type which is a copy
4777 of type Color. If we call that implicit type RGB_ColorB ("B" is
4778 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4779 As a result, when an expression references any of the enumeral
4780 by name (Eg. "print green"), the expression is technically
4781 ambiguous and the user should be asked to disambiguate. But
4782 doing so would only hinder the user, since it wouldn't matter
4783 what choice he makes, the outcome would always be the same.
4784 So, for practical purposes, we consider them as the same. */
4785
4786static int
4787symbols_are_identical_enums (struct ada_symbol_info *syms, int nsyms)
4788{
4789 int i;
4790
4791 /* Before performing a thorough comparison check of each type,
4792 we perform a series of inexpensive checks. We expect that these
4793 checks will quickly fail in the vast majority of cases, and thus
4794 help prevent the unnecessary use of a more expensive comparison.
4795 Said comparison also expects us to make some of these checks
4796 (see ada_identical_enum_types_p). */
4797
4798 /* Quick check: All symbols should have an enum type. */
4799 for (i = 0; i < nsyms; i++)
4800 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM)
4801 return 0;
4802
4803 /* Quick check: They should all have the same value. */
4804 for (i = 1; i < nsyms; i++)
4805 if (SYMBOL_VALUE (syms[i].sym) != SYMBOL_VALUE (syms[0].sym))
4806 return 0;
4807
4808 /* Quick check: They should all have the same number of enumerals. */
4809 for (i = 1; i < nsyms; i++)
4810 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].sym))
4811 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].sym)))
4812 return 0;
4813
4814 /* All the sanity checks passed, so we might have a set of
4815 identical enumeration types. Perform a more complete
4816 comparison of the type of each symbol. */
4817 for (i = 1; i < nsyms; i++)
4818 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].sym),
4819 SYMBOL_TYPE (syms[0].sym)))
4820 return 0;
4821
4822 return 1;
4823}
4824
96d887e8
PH
4825/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4826 duplicate other symbols in the list (The only case I know of where
4827 this happens is when object files containing stabs-in-ecoff are
4828 linked with files containing ordinary ecoff debugging symbols (or no
4829 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4830 Returns the number of items in the modified list. */
4c4b4cd2 4831
96d887e8
PH
4832static int
4833remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4834{
4835 int i, j;
4c4b4cd2 4836
8f17729f
JB
4837 /* We should never be called with less than 2 symbols, as there
4838 cannot be any extra symbol in that case. But it's easy to
4839 handle, since we have nothing to do in that case. */
4840 if (nsyms < 2)
4841 return nsyms;
4842
96d887e8
PH
4843 i = 0;
4844 while (i < nsyms)
4845 {
a35ddb44 4846 int remove_p = 0;
339c13b6
JB
4847
4848 /* If two symbols have the same name and one of them is a stub type,
4849 the get rid of the stub. */
4850
4851 if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym))
4852 && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL)
4853 {
4854 for (j = 0; j < nsyms; j++)
4855 {
4856 if (j != i
4857 && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym))
4858 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4859 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4860 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0)
a35ddb44 4861 remove_p = 1;
339c13b6
JB
4862 }
4863 }
4864
4865 /* Two symbols with the same name, same class and same address
4866 should be identical. */
4867
4868 else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
96d887e8
PH
4869 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4870 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4871 {
4872 for (j = 0; j < nsyms; j += 1)
4873 {
4874 if (i != j
4875 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4876 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
76a01679 4877 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
96d887e8
PH
4878 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4879 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4880 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
a35ddb44 4881 remove_p = 1;
4c4b4cd2 4882 }
4c4b4cd2 4883 }
339c13b6 4884
a35ddb44 4885 if (remove_p)
339c13b6
JB
4886 {
4887 for (j = i + 1; j < nsyms; j += 1)
4888 syms[j - 1] = syms[j];
4889 nsyms -= 1;
4890 }
4891
96d887e8 4892 i += 1;
14f9c5c9 4893 }
8f17729f
JB
4894
4895 /* If all the remaining symbols are identical enumerals, then
4896 just keep the first one and discard the rest.
4897
4898 Unlike what we did previously, we do not discard any entry
4899 unless they are ALL identical. This is because the symbol
4900 comparison is not a strict comparison, but rather a practical
4901 comparison. If all symbols are considered identical, then
4902 we can just go ahead and use the first one and discard the rest.
4903 But if we cannot reduce the list to a single element, we have
4904 to ask the user to disambiguate anyways. And if we have to
4905 present a multiple-choice menu, it's less confusing if the list
4906 isn't missing some choices that were identical and yet distinct. */
4907 if (symbols_are_identical_enums (syms, nsyms))
4908 nsyms = 1;
4909
96d887e8 4910 return nsyms;
14f9c5c9
AS
4911}
4912
96d887e8
PH
4913/* Given a type that corresponds to a renaming entity, use the type name
4914 to extract the scope (package name or function name, fully qualified,
4915 and following the GNAT encoding convention) where this renaming has been
4916 defined. The string returned needs to be deallocated after use. */
4c4b4cd2 4917
96d887e8
PH
4918static char *
4919xget_renaming_scope (struct type *renaming_type)
14f9c5c9 4920{
96d887e8 4921 /* The renaming types adhere to the following convention:
0963b4bd 4922 <scope>__<rename>___<XR extension>.
96d887e8
PH
4923 So, to extract the scope, we search for the "___XR" extension,
4924 and then backtrack until we find the first "__". */
76a01679 4925
96d887e8
PH
4926 const char *name = type_name_no_tag (renaming_type);
4927 char *suffix = strstr (name, "___XR");
4928 char *last;
4929 int scope_len;
4930 char *scope;
14f9c5c9 4931
96d887e8
PH
4932 /* Now, backtrack a bit until we find the first "__". Start looking
4933 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 4934
96d887e8
PH
4935 for (last = suffix - 3; last > name; last--)
4936 if (last[0] == '_' && last[1] == '_')
4937 break;
76a01679 4938
96d887e8 4939 /* Make a copy of scope and return it. */
14f9c5c9 4940
96d887e8
PH
4941 scope_len = last - name;
4942 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
14f9c5c9 4943
96d887e8
PH
4944 strncpy (scope, name, scope_len);
4945 scope[scope_len] = '\0';
4c4b4cd2 4946
96d887e8 4947 return scope;
4c4b4cd2
PH
4948}
4949
96d887e8 4950/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 4951
96d887e8
PH
4952static int
4953is_package_name (const char *name)
4c4b4cd2 4954{
96d887e8
PH
4955 /* Here, We take advantage of the fact that no symbols are generated
4956 for packages, while symbols are generated for each function.
4957 So the condition for NAME represent a package becomes equivalent
4958 to NAME not existing in our list of symbols. There is only one
4959 small complication with library-level functions (see below). */
4c4b4cd2 4960
96d887e8 4961 char *fun_name;
76a01679 4962
96d887e8
PH
4963 /* If it is a function that has not been defined at library level,
4964 then we should be able to look it up in the symbols. */
4965 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4966 return 0;
14f9c5c9 4967
96d887e8
PH
4968 /* Library-level function names start with "_ada_". See if function
4969 "_ada_" followed by NAME can be found. */
14f9c5c9 4970
96d887e8 4971 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 4972 functions names cannot contain "__" in them. */
96d887e8
PH
4973 if (strstr (name, "__") != NULL)
4974 return 0;
4c4b4cd2 4975
b435e160 4976 fun_name = xstrprintf ("_ada_%s", name);
14f9c5c9 4977
96d887e8
PH
4978 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4979}
14f9c5c9 4980
96d887e8 4981/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 4982 not visible from FUNCTION_NAME. */
14f9c5c9 4983
96d887e8 4984static int
0d5cff50 4985old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 4986{
aeb5907d 4987 char *scope;
1509e573 4988 struct cleanup *old_chain;
aeb5907d
JB
4989
4990 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4991 return 0;
4992
4993 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
1509e573 4994 old_chain = make_cleanup (xfree, scope);
14f9c5c9 4995
96d887e8
PH
4996 /* If the rename has been defined in a package, then it is visible. */
4997 if (is_package_name (scope))
1509e573
JB
4998 {
4999 do_cleanups (old_chain);
5000 return 0;
5001 }
14f9c5c9 5002
96d887e8
PH
5003 /* Check that the rename is in the current function scope by checking
5004 that its name starts with SCOPE. */
76a01679 5005
96d887e8
PH
5006 /* If the function name starts with "_ada_", it means that it is
5007 a library-level function. Strip this prefix before doing the
5008 comparison, as the encoding for the renaming does not contain
5009 this prefix. */
5010 if (strncmp (function_name, "_ada_", 5) == 0)
5011 function_name += 5;
f26caa11 5012
1509e573
JB
5013 {
5014 int is_invisible = strncmp (function_name, scope, strlen (scope)) != 0;
5015
5016 do_cleanups (old_chain);
5017 return is_invisible;
5018 }
f26caa11
PH
5019}
5020
aeb5907d
JB
5021/* Remove entries from SYMS that corresponds to a renaming entity that
5022 is not visible from the function associated with CURRENT_BLOCK or
5023 that is superfluous due to the presence of more specific renaming
5024 information. Places surviving symbols in the initial entries of
5025 SYMS and returns the number of surviving symbols.
96d887e8
PH
5026
5027 Rationale:
aeb5907d
JB
5028 First, in cases where an object renaming is implemented as a
5029 reference variable, GNAT may produce both the actual reference
5030 variable and the renaming encoding. In this case, we discard the
5031 latter.
5032
5033 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
5034 entity. Unfortunately, STABS currently does not support the definition
5035 of types that are local to a given lexical block, so all renamings types
5036 are emitted at library level. As a consequence, if an application
5037 contains two renaming entities using the same name, and a user tries to
5038 print the value of one of these entities, the result of the ada symbol
5039 lookup will also contain the wrong renaming type.
f26caa11 5040
96d887e8
PH
5041 This function partially covers for this limitation by attempting to
5042 remove from the SYMS list renaming symbols that should be visible
5043 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5044 method with the current information available. The implementation
5045 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5046
5047 - When the user tries to print a rename in a function while there
5048 is another rename entity defined in a package: Normally, the
5049 rename in the function has precedence over the rename in the
5050 package, so the latter should be removed from the list. This is
5051 currently not the case.
5052
5053 - This function will incorrectly remove valid renames if
5054 the CURRENT_BLOCK corresponds to a function which symbol name
5055 has been changed by an "Export" pragma. As a consequence,
5056 the user will be unable to print such rename entities. */
4c4b4cd2 5057
14f9c5c9 5058static int
aeb5907d
JB
5059remove_irrelevant_renamings (struct ada_symbol_info *syms,
5060 int nsyms, const struct block *current_block)
4c4b4cd2
PH
5061{
5062 struct symbol *current_function;
0d5cff50 5063 const char *current_function_name;
4c4b4cd2 5064 int i;
aeb5907d
JB
5065 int is_new_style_renaming;
5066
5067 /* If there is both a renaming foo___XR... encoded as a variable and
5068 a simple variable foo in the same block, discard the latter.
0963b4bd 5069 First, zero out such symbols, then compress. */
aeb5907d
JB
5070 is_new_style_renaming = 0;
5071 for (i = 0; i < nsyms; i += 1)
5072 {
5073 struct symbol *sym = syms[i].sym;
270140bd 5074 const struct block *block = syms[i].block;
aeb5907d
JB
5075 const char *name;
5076 const char *suffix;
5077
5078 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5079 continue;
5080 name = SYMBOL_LINKAGE_NAME (sym);
5081 suffix = strstr (name, "___XR");
5082
5083 if (suffix != NULL)
5084 {
5085 int name_len = suffix - name;
5086 int j;
5b4ee69b 5087
aeb5907d
JB
5088 is_new_style_renaming = 1;
5089 for (j = 0; j < nsyms; j += 1)
5090 if (i != j && syms[j].sym != NULL
5091 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
5092 name_len) == 0
5093 && block == syms[j].block)
5094 syms[j].sym = NULL;
5095 }
5096 }
5097 if (is_new_style_renaming)
5098 {
5099 int j, k;
5100
5101 for (j = k = 0; j < nsyms; j += 1)
5102 if (syms[j].sym != NULL)
5103 {
5104 syms[k] = syms[j];
5105 k += 1;
5106 }
5107 return k;
5108 }
4c4b4cd2
PH
5109
5110 /* Extract the function name associated to CURRENT_BLOCK.
5111 Abort if unable to do so. */
76a01679 5112
4c4b4cd2
PH
5113 if (current_block == NULL)
5114 return nsyms;
76a01679 5115
7f0df278 5116 current_function = block_linkage_function (current_block);
4c4b4cd2
PH
5117 if (current_function == NULL)
5118 return nsyms;
5119
5120 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5121 if (current_function_name == NULL)
5122 return nsyms;
5123
5124 /* Check each of the symbols, and remove it from the list if it is
5125 a type corresponding to a renaming that is out of the scope of
5126 the current block. */
5127
5128 i = 0;
5129 while (i < nsyms)
5130 {
aeb5907d
JB
5131 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
5132 == ADA_OBJECT_RENAMING
5133 && old_renaming_is_invisible (syms[i].sym, current_function_name))
4c4b4cd2
PH
5134 {
5135 int j;
5b4ee69b 5136
aeb5907d 5137 for (j = i + 1; j < nsyms; j += 1)
76a01679 5138 syms[j - 1] = syms[j];
4c4b4cd2
PH
5139 nsyms -= 1;
5140 }
5141 else
5142 i += 1;
5143 }
5144
5145 return nsyms;
5146}
5147
339c13b6
JB
5148/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5149 whose name and domain match NAME and DOMAIN respectively.
5150 If no match was found, then extend the search to "enclosing"
5151 routines (in other words, if we're inside a nested function,
5152 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
5153 If WILD_MATCH_P is nonzero, perform the naming matching in
5154 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
5155
5156 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5157
5158static void
5159ada_add_local_symbols (struct obstack *obstackp, const char *name,
f0c5f9b2 5160 const struct block *block, domain_enum domain,
d0a8ab18 5161 int wild_match_p)
339c13b6
JB
5162{
5163 int block_depth = 0;
5164
5165 while (block != NULL)
5166 {
5167 block_depth += 1;
d0a8ab18
JB
5168 ada_add_block_symbols (obstackp, block, name, domain, NULL,
5169 wild_match_p);
339c13b6
JB
5170
5171 /* If we found a non-function match, assume that's the one. */
5172 if (is_nonfunction (defns_collected (obstackp, 0),
5173 num_defns_collected (obstackp)))
5174 return;
5175
5176 block = BLOCK_SUPERBLOCK (block);
5177 }
5178
5179 /* If no luck so far, try to find NAME as a local symbol in some lexically
5180 enclosing subprogram. */
5181 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
d0a8ab18 5182 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match_p);
339c13b6
JB
5183}
5184
ccefe4c4 5185/* An object of this type is used as the user_data argument when
40658b94 5186 calling the map_matching_symbols method. */
ccefe4c4 5187
40658b94 5188struct match_data
ccefe4c4 5189{
40658b94 5190 struct objfile *objfile;
ccefe4c4 5191 struct obstack *obstackp;
40658b94
PH
5192 struct symbol *arg_sym;
5193 int found_sym;
ccefe4c4
TT
5194};
5195
40658b94
PH
5196/* A callback for add_matching_symbols that adds SYM, found in BLOCK,
5197 to a list of symbols. DATA0 is a pointer to a struct match_data *
5198 containing the obstack that collects the symbol list, the file that SYM
5199 must come from, a flag indicating whether a non-argument symbol has
5200 been found in the current block, and the last argument symbol
5201 passed in SYM within the current block (if any). When SYM is null,
5202 marking the end of a block, the argument symbol is added if no
5203 other has been found. */
ccefe4c4 5204
40658b94
PH
5205static int
5206aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 5207{
40658b94
PH
5208 struct match_data *data = (struct match_data *) data0;
5209
5210 if (sym == NULL)
5211 {
5212 if (!data->found_sym && data->arg_sym != NULL)
5213 add_defn_to_vec (data->obstackp,
5214 fixup_symbol_section (data->arg_sym, data->objfile),
5215 block);
5216 data->found_sym = 0;
5217 data->arg_sym = NULL;
5218 }
5219 else
5220 {
5221 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5222 return 0;
5223 else if (SYMBOL_IS_ARGUMENT (sym))
5224 data->arg_sym = sym;
5225 else
5226 {
5227 data->found_sym = 1;
5228 add_defn_to_vec (data->obstackp,
5229 fixup_symbol_section (sym, data->objfile),
5230 block);
5231 }
5232 }
5233 return 0;
5234}
5235
db230ce3
JB
5236/* Implements compare_names, but only applying the comparision using
5237 the given CASING. */
5b4ee69b 5238
40658b94 5239static int
db230ce3
JB
5240compare_names_with_case (const char *string1, const char *string2,
5241 enum case_sensitivity casing)
40658b94
PH
5242{
5243 while (*string1 != '\0' && *string2 != '\0')
5244 {
db230ce3
JB
5245 char c1, c2;
5246
40658b94
PH
5247 if (isspace (*string1) || isspace (*string2))
5248 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
5249
5250 if (casing == case_sensitive_off)
5251 {
5252 c1 = tolower (*string1);
5253 c2 = tolower (*string2);
5254 }
5255 else
5256 {
5257 c1 = *string1;
5258 c2 = *string2;
5259 }
5260 if (c1 != c2)
40658b94 5261 break;
db230ce3 5262
40658b94
PH
5263 string1 += 1;
5264 string2 += 1;
5265 }
db230ce3 5266
40658b94
PH
5267 switch (*string1)
5268 {
5269 case '(':
5270 return strcmp_iw_ordered (string1, string2);
5271 case '_':
5272 if (*string2 == '\0')
5273 {
052874e8 5274 if (is_name_suffix (string1))
40658b94
PH
5275 return 0;
5276 else
1a1d5513 5277 return 1;
40658b94 5278 }
dbb8534f 5279 /* FALLTHROUGH */
40658b94
PH
5280 default:
5281 if (*string2 == '(')
5282 return strcmp_iw_ordered (string1, string2);
5283 else
db230ce3
JB
5284 {
5285 if (casing == case_sensitive_off)
5286 return tolower (*string1) - tolower (*string2);
5287 else
5288 return *string1 - *string2;
5289 }
40658b94 5290 }
ccefe4c4
TT
5291}
5292
db230ce3
JB
5293/* Compare STRING1 to STRING2, with results as for strcmp.
5294 Compatible with strcmp_iw_ordered in that...
5295
5296 strcmp_iw_ordered (STRING1, STRING2) <= 0
5297
5298 ... implies...
5299
5300 compare_names (STRING1, STRING2) <= 0
5301
5302 (they may differ as to what symbols compare equal). */
5303
5304static int
5305compare_names (const char *string1, const char *string2)
5306{
5307 int result;
5308
5309 /* Similar to what strcmp_iw_ordered does, we need to perform
5310 a case-insensitive comparison first, and only resort to
5311 a second, case-sensitive, comparison if the first one was
5312 not sufficient to differentiate the two strings. */
5313
5314 result = compare_names_with_case (string1, string2, case_sensitive_off);
5315 if (result == 0)
5316 result = compare_names_with_case (string1, string2, case_sensitive_on);
5317
5318 return result;
5319}
5320
339c13b6
JB
5321/* Add to OBSTACKP all non-local symbols whose name and domain match
5322 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
5323 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
5324
5325static void
40658b94
PH
5326add_nonlocal_symbols (struct obstack *obstackp, const char *name,
5327 domain_enum domain, int global,
5328 int is_wild_match)
339c13b6
JB
5329{
5330 struct objfile *objfile;
40658b94 5331 struct match_data data;
339c13b6 5332
6475f2fe 5333 memset (&data, 0, sizeof data);
ccefe4c4 5334 data.obstackp = obstackp;
339c13b6 5335
ccefe4c4 5336 ALL_OBJFILES (objfile)
40658b94
PH
5337 {
5338 data.objfile = objfile;
5339
5340 if (is_wild_match)
b50c8614
KS
5341 {
5342 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5343 aux_add_nonlocal_symbols,
5344 &data, wild_match, NULL);
5345 if (domain == VAR_DOMAIN)
5346 objfile->sf->qf->map_matching_symbols (objfile, name,
5347 STRUCT_DOMAIN, global,
5348 aux_add_nonlocal_symbols,
5349 &data, wild_match, NULL);
5350 }
40658b94 5351 else
b50c8614
KS
5352 {
5353 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5354 aux_add_nonlocal_symbols,
5355 &data, full_match,
5356 compare_names);
5357 if (domain == VAR_DOMAIN)
5358 objfile->sf->qf->map_matching_symbols (objfile, name,
5359 STRUCT_DOMAIN, global,
5360 aux_add_nonlocal_symbols,
5361 &data, full_match,
5362 compare_names);
5363 }
40658b94
PH
5364 }
5365
5366 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5367 {
5368 ALL_OBJFILES (objfile)
5369 {
5370 char *name1 = alloca (strlen (name) + sizeof ("_ada_"));
5371 strcpy (name1, "_ada_");
5372 strcpy (name1 + sizeof ("_ada_") - 1, name);
5373 data.objfile = objfile;
ade7ed9e
DE
5374 objfile->sf->qf->map_matching_symbols (objfile, name1, domain,
5375 global,
0963b4bd
MS
5376 aux_add_nonlocal_symbols,
5377 &data,
40658b94
PH
5378 full_match, compare_names);
5379 }
5380 }
339c13b6
JB
5381}
5382
4eeaa230
DE
5383/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and, if full_search is
5384 non-zero, enclosing scope and in global scopes, returning the number of
5385 matches.
9f88c959 5386 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4c4b4cd2 5387 indicating the symbols found and the blocks and symbol tables (if
4eeaa230
DE
5388 any) in which they were found. This vector is transient---good only to
5389 the next call of ada_lookup_symbol_list.
5390
5391 When full_search is non-zero, any non-function/non-enumeral
4c4b4cd2
PH
5392 symbol match within the nest of blocks whose innermost member is BLOCK0,
5393 is the one match returned (no other matches in that or
d9680e73 5394 enclosing blocks is returned). If there are any matches in or
4eeaa230
DE
5395 surrounding BLOCK0, then these alone are returned.
5396
9f88c959 5397 Names prefixed with "standard__" are handled specially: "standard__"
4c4b4cd2 5398 is first stripped off, and only static and global symbols are searched. */
14f9c5c9 5399
4eeaa230
DE
5400static int
5401ada_lookup_symbol_list_worker (const char *name0, const struct block *block0,
5402 domain_enum namespace,
5403 struct ada_symbol_info **results,
5404 int full_search)
14f9c5c9
AS
5405{
5406 struct symbol *sym;
f0c5f9b2 5407 const struct block *block;
4c4b4cd2 5408 const char *name;
82ccd55e 5409 const int wild_match_p = should_use_wild_match (name0);
14f9c5c9 5410 int cacheIfUnique;
4c4b4cd2 5411 int ndefns;
14f9c5c9 5412
4c4b4cd2
PH
5413 obstack_free (&symbol_list_obstack, NULL);
5414 obstack_init (&symbol_list_obstack);
14f9c5c9 5415
14f9c5c9
AS
5416 cacheIfUnique = 0;
5417
5418 /* Search specified block and its superiors. */
5419
4c4b4cd2 5420 name = name0;
f0c5f9b2 5421 block = block0;
339c13b6
JB
5422
5423 /* Special case: If the user specifies a symbol name inside package
5424 Standard, do a non-wild matching of the symbol name without
5425 the "standard__" prefix. This was primarily introduced in order
5426 to allow the user to specifically access the standard exceptions
5427 using, for instance, Standard.Constraint_Error when Constraint_Error
5428 is ambiguous (due to the user defining its own Constraint_Error
5429 entity inside its program). */
4c4b4cd2
PH
5430 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
5431 {
4c4b4cd2
PH
5432 block = NULL;
5433 name = name0 + sizeof ("standard__") - 1;
5434 }
5435
339c13b6 5436 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5437
4eeaa230
DE
5438 if (block != NULL)
5439 {
5440 if (full_search)
5441 {
5442 ada_add_local_symbols (&symbol_list_obstack, name, block,
5443 namespace, wild_match_p);
5444 }
5445 else
5446 {
5447 /* In the !full_search case we're are being called by
5448 ada_iterate_over_symbols, and we don't want to search
5449 superblocks. */
5450 ada_add_block_symbols (&symbol_list_obstack, block, name,
5451 namespace, NULL, wild_match_p);
5452 }
5453 if (num_defns_collected (&symbol_list_obstack) > 0 || !full_search)
5454 goto done;
5455 }
d2e4a39e 5456
339c13b6
JB
5457 /* No non-global symbols found. Check our cache to see if we have
5458 already performed this search before. If we have, then return
5459 the same result. */
5460
14f9c5c9 5461 cacheIfUnique = 1;
2570f2b7 5462 if (lookup_cached_symbol (name0, namespace, &sym, &block))
4c4b4cd2
PH
5463 {
5464 if (sym != NULL)
2570f2b7 5465 add_defn_to_vec (&symbol_list_obstack, sym, block);
4c4b4cd2
PH
5466 goto done;
5467 }
14f9c5c9 5468
339c13b6
JB
5469 /* Search symbols from all global blocks. */
5470
40658b94 5471 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 1,
82ccd55e 5472 wild_match_p);
d2e4a39e 5473
4c4b4cd2 5474 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5475 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5476
4c4b4cd2 5477 if (num_defns_collected (&symbol_list_obstack) == 0)
40658b94 5478 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 0,
82ccd55e 5479 wild_match_p);
14f9c5c9 5480
4c4b4cd2
PH
5481done:
5482 ndefns = num_defns_collected (&symbol_list_obstack);
5483 *results = defns_collected (&symbol_list_obstack, 1);
5484
5485 ndefns = remove_extra_symbols (*results, ndefns);
5486
2ad01556 5487 if (ndefns == 0 && full_search)
2570f2b7 5488 cache_symbol (name0, namespace, NULL, NULL);
14f9c5c9 5489
2ad01556 5490 if (ndefns == 1 && full_search && cacheIfUnique)
2570f2b7 5491 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
14f9c5c9 5492
aeb5907d 5493 ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
14f9c5c9 5494
14f9c5c9
AS
5495 return ndefns;
5496}
5497
4eeaa230
DE
5498/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and
5499 in global scopes, returning the number of matches, and setting *RESULTS
5500 to a vector of (SYM,BLOCK) tuples.
5501 See ada_lookup_symbol_list_worker for further details. */
5502
5503int
5504ada_lookup_symbol_list (const char *name0, const struct block *block0,
5505 domain_enum domain, struct ada_symbol_info **results)
5506{
5507 return ada_lookup_symbol_list_worker (name0, block0, domain, results, 1);
5508}
5509
5510/* Implementation of the la_iterate_over_symbols method. */
5511
5512static void
5513ada_iterate_over_symbols (const struct block *block,
5514 const char *name, domain_enum domain,
5515 symbol_found_callback_ftype *callback,
5516 void *data)
5517{
5518 int ndefs, i;
5519 struct ada_symbol_info *results;
5520
5521 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5522 for (i = 0; i < ndefs; ++i)
5523 {
5524 if (! (*callback) (results[i].sym, data))
5525 break;
5526 }
5527}
5528
f8eba3c6
TT
5529/* If NAME is the name of an entity, return a string that should
5530 be used to look that entity up in Ada units. This string should
5531 be deallocated after use using xfree.
5532
5533 NAME can have any form that the "break" or "print" commands might
5534 recognize. In other words, it does not have to be the "natural"
5535 name, or the "encoded" name. */
5536
5537char *
5538ada_name_for_lookup (const char *name)
5539{
5540 char *canon;
5541 int nlen = strlen (name);
5542
5543 if (name[0] == '<' && name[nlen - 1] == '>')
5544 {
5545 canon = xmalloc (nlen - 1);
5546 memcpy (canon, name + 1, nlen - 2);
5547 canon[nlen - 2] = '\0';
5548 }
5549 else
5550 canon = xstrdup (ada_encode (ada_fold_name (name)));
5551 return canon;
5552}
5553
4e5c77fe
JB
5554/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5555 to 1, but choosing the first symbol found if there are multiple
5556 choices.
5557
5e2336be
JB
5558 The result is stored in *INFO, which must be non-NULL.
5559 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5560
5561void
5562ada_lookup_encoded_symbol (const char *name, const struct block *block,
5563 domain_enum namespace,
5e2336be 5564 struct ada_symbol_info *info)
14f9c5c9 5565{
4c4b4cd2 5566 struct ada_symbol_info *candidates;
14f9c5c9
AS
5567 int n_candidates;
5568
5e2336be
JB
5569 gdb_assert (info != NULL);
5570 memset (info, 0, sizeof (struct ada_symbol_info));
4e5c77fe 5571
4eeaa230 5572 n_candidates = ada_lookup_symbol_list (name, block, namespace, &candidates);
14f9c5c9 5573 if (n_candidates == 0)
4e5c77fe 5574 return;
4c4b4cd2 5575
5e2336be
JB
5576 *info = candidates[0];
5577 info->sym = fixup_symbol_section (info->sym, NULL);
4e5c77fe 5578}
aeb5907d
JB
5579
5580/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5581 scope and in global scopes, or NULL if none. NAME is folded and
5582 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5583 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5584 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5585
aeb5907d
JB
5586struct symbol *
5587ada_lookup_symbol (const char *name, const struct block *block0,
21b556f4 5588 domain_enum namespace, int *is_a_field_of_this)
aeb5907d 5589{
5e2336be 5590 struct ada_symbol_info info;
4e5c77fe 5591
aeb5907d
JB
5592 if (is_a_field_of_this != NULL)
5593 *is_a_field_of_this = 0;
5594
4e5c77fe 5595 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
5e2336be
JB
5596 block0, namespace, &info);
5597 return info.sym;
4c4b4cd2 5598}
14f9c5c9 5599
4c4b4cd2
PH
5600static struct symbol *
5601ada_lookup_symbol_nonlocal (const char *name,
76a01679 5602 const struct block *block,
21b556f4 5603 const domain_enum domain)
4c4b4cd2 5604{
94af9270 5605 return ada_lookup_symbol (name, block_static_block (block), domain, NULL);
14f9c5c9
AS
5606}
5607
5608
4c4b4cd2
PH
5609/* True iff STR is a possible encoded suffix of a normal Ada name
5610 that is to be ignored for matching purposes. Suffixes of parallel
5611 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5612 are given by any of the regular expressions:
4c4b4cd2 5613
babe1480
JB
5614 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5615 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5616 TKB [subprogram suffix for task bodies]
babe1480 5617 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5618 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5619
5620 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5621 match is performed. This sequence is used to differentiate homonyms,
5622 is an optional part of a valid name suffix. */
4c4b4cd2 5623
14f9c5c9 5624static int
d2e4a39e 5625is_name_suffix (const char *str)
14f9c5c9
AS
5626{
5627 int k;
4c4b4cd2
PH
5628 const char *matching;
5629 const int len = strlen (str);
5630
babe1480
JB
5631 /* Skip optional leading __[0-9]+. */
5632
4c4b4cd2
PH
5633 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5634 {
babe1480
JB
5635 str += 3;
5636 while (isdigit (str[0]))
5637 str += 1;
4c4b4cd2 5638 }
babe1480
JB
5639
5640 /* [.$][0-9]+ */
4c4b4cd2 5641
babe1480 5642 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5643 {
babe1480 5644 matching = str + 1;
4c4b4cd2
PH
5645 while (isdigit (matching[0]))
5646 matching += 1;
5647 if (matching[0] == '\0')
5648 return 1;
5649 }
5650
5651 /* ___[0-9]+ */
babe1480 5652
4c4b4cd2
PH
5653 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5654 {
5655 matching = str + 3;
5656 while (isdigit (matching[0]))
5657 matching += 1;
5658 if (matching[0] == '\0')
5659 return 1;
5660 }
5661
9ac7f98e
JB
5662 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5663
5664 if (strcmp (str, "TKB") == 0)
5665 return 1;
5666
529cad9c
PH
5667#if 0
5668 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
5669 with a N at the end. Unfortunately, the compiler uses the same
5670 convention for other internal types it creates. So treating
529cad9c 5671 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
5672 some regressions. For instance, consider the case of an enumerated
5673 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
5674 name ends with N.
5675 Having a single character like this as a suffix carrying some
0963b4bd 5676 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
5677 to be something like "_N" instead. In the meantime, do not do
5678 the following check. */
5679 /* Protected Object Subprograms */
5680 if (len == 1 && str [0] == 'N')
5681 return 1;
5682#endif
5683
5684 /* _E[0-9]+[bs]$ */
5685 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5686 {
5687 matching = str + 3;
5688 while (isdigit (matching[0]))
5689 matching += 1;
5690 if ((matching[0] == 'b' || matching[0] == 's')
5691 && matching [1] == '\0')
5692 return 1;
5693 }
5694
4c4b4cd2
PH
5695 /* ??? We should not modify STR directly, as we are doing below. This
5696 is fine in this case, but may become problematic later if we find
5697 that this alternative did not work, and want to try matching
5698 another one from the begining of STR. Since we modified it, we
5699 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
5700 if (str[0] == 'X')
5701 {
5702 str += 1;
d2e4a39e 5703 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
5704 {
5705 if (str[0] != 'n' && str[0] != 'b')
5706 return 0;
5707 str += 1;
5708 }
14f9c5c9 5709 }
babe1480 5710
14f9c5c9
AS
5711 if (str[0] == '\000')
5712 return 1;
babe1480 5713
d2e4a39e 5714 if (str[0] == '_')
14f9c5c9
AS
5715 {
5716 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 5717 return 0;
d2e4a39e 5718 if (str[2] == '_')
4c4b4cd2 5719 {
61ee279c
PH
5720 if (strcmp (str + 3, "JM") == 0)
5721 return 1;
5722 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5723 the LJM suffix in favor of the JM one. But we will
5724 still accept LJM as a valid suffix for a reasonable
5725 amount of time, just to allow ourselves to debug programs
5726 compiled using an older version of GNAT. */
4c4b4cd2
PH
5727 if (strcmp (str + 3, "LJM") == 0)
5728 return 1;
5729 if (str[3] != 'X')
5730 return 0;
1265e4aa
JB
5731 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5732 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
5733 return 1;
5734 if (str[4] == 'R' && str[5] != 'T')
5735 return 1;
5736 return 0;
5737 }
5738 if (!isdigit (str[2]))
5739 return 0;
5740 for (k = 3; str[k] != '\0'; k += 1)
5741 if (!isdigit (str[k]) && str[k] != '_')
5742 return 0;
14f9c5c9
AS
5743 return 1;
5744 }
4c4b4cd2 5745 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 5746 {
4c4b4cd2
PH
5747 for (k = 2; str[k] != '\0'; k += 1)
5748 if (!isdigit (str[k]) && str[k] != '_')
5749 return 0;
14f9c5c9
AS
5750 return 1;
5751 }
5752 return 0;
5753}
d2e4a39e 5754
aeb5907d
JB
5755/* Return non-zero if the string starting at NAME and ending before
5756 NAME_END contains no capital letters. */
529cad9c
PH
5757
5758static int
5759is_valid_name_for_wild_match (const char *name0)
5760{
5761 const char *decoded_name = ada_decode (name0);
5762 int i;
5763
5823c3ef
JB
5764 /* If the decoded name starts with an angle bracket, it means that
5765 NAME0 does not follow the GNAT encoding format. It should then
5766 not be allowed as a possible wild match. */
5767 if (decoded_name[0] == '<')
5768 return 0;
5769
529cad9c
PH
5770 for (i=0; decoded_name[i] != '\0'; i++)
5771 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5772 return 0;
5773
5774 return 1;
5775}
5776
73589123
PH
5777/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5778 that could start a simple name. Assumes that *NAMEP points into
5779 the string beginning at NAME0. */
4c4b4cd2 5780
14f9c5c9 5781static int
73589123 5782advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 5783{
73589123 5784 const char *name = *namep;
5b4ee69b 5785
5823c3ef 5786 while (1)
14f9c5c9 5787 {
aa27d0b3 5788 int t0, t1;
73589123
PH
5789
5790 t0 = *name;
5791 if (t0 == '_')
5792 {
5793 t1 = name[1];
5794 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5795 {
5796 name += 1;
5797 if (name == name0 + 5 && strncmp (name0, "_ada", 4) == 0)
5798 break;
5799 else
5800 name += 1;
5801 }
aa27d0b3
JB
5802 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5803 || name[2] == target0))
73589123
PH
5804 {
5805 name += 2;
5806 break;
5807 }
5808 else
5809 return 0;
5810 }
5811 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5812 name += 1;
5813 else
5823c3ef 5814 return 0;
73589123
PH
5815 }
5816
5817 *namep = name;
5818 return 1;
5819}
5820
5821/* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5822 informational suffixes of NAME (i.e., for which is_name_suffix is
5823 true). Assumes that PATN is a lower-cased Ada simple name. */
5824
5825static int
5826wild_match (const char *name, const char *patn)
5827{
22e048c9 5828 const char *p;
73589123
PH
5829 const char *name0 = name;
5830
5831 while (1)
5832 {
5833 const char *match = name;
5834
5835 if (*name == *patn)
5836 {
5837 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5838 if (*p != *name)
5839 break;
5840 if (*p == '\0' && is_name_suffix (name))
5841 return match != name0 && !is_valid_name_for_wild_match (name0);
5842
5843 if (name[-1] == '_')
5844 name -= 1;
5845 }
5846 if (!advance_wild_match (&name, name0, *patn))
5847 return 1;
96d887e8 5848 }
96d887e8
PH
5849}
5850
40658b94
PH
5851/* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
5852 informational suffix. */
5853
c4d840bd
PH
5854static int
5855full_match (const char *sym_name, const char *search_name)
5856{
40658b94 5857 return !match_name (sym_name, search_name, 0);
c4d840bd
PH
5858}
5859
5860
96d887e8
PH
5861/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5862 vector *defn_symbols, updating the list of symbols in OBSTACKP
0963b4bd 5863 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4eeaa230 5864 OBJFILE is the section containing BLOCK. */
96d887e8
PH
5865
5866static void
5867ada_add_block_symbols (struct obstack *obstackp,
f0c5f9b2 5868 const struct block *block, const char *name,
96d887e8 5869 domain_enum domain, struct objfile *objfile,
2570f2b7 5870 int wild)
96d887e8 5871{
8157b174 5872 struct block_iterator iter;
96d887e8
PH
5873 int name_len = strlen (name);
5874 /* A matching argument symbol, if any. */
5875 struct symbol *arg_sym;
5876 /* Set true when we find a matching non-argument symbol. */
5877 int found_sym;
5878 struct symbol *sym;
5879
5880 arg_sym = NULL;
5881 found_sym = 0;
5882 if (wild)
5883 {
8157b174
TT
5884 for (sym = block_iter_match_first (block, name, wild_match, &iter);
5885 sym != NULL; sym = block_iter_match_next (name, wild_match, &iter))
76a01679 5886 {
b50c8614 5887 if (ada_symbol_matches_domain (SYMBOL_DOMAIN (sym), domain)
73589123 5888 && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0)
76a01679 5889 {
2a2d4dc3
AS
5890 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5891 continue;
5892 else if (SYMBOL_IS_ARGUMENT (sym))
5893 arg_sym = sym;
5894 else
5895 {
76a01679
JB
5896 found_sym = 1;
5897 add_defn_to_vec (obstackp,
5898 fixup_symbol_section (sym, objfile),
2570f2b7 5899 block);
76a01679
JB
5900 }
5901 }
5902 }
96d887e8
PH
5903 }
5904 else
5905 {
8157b174
TT
5906 for (sym = block_iter_match_first (block, name, full_match, &iter);
5907 sym != NULL; sym = block_iter_match_next (name, full_match, &iter))
76a01679 5908 {
b50c8614 5909 if (ada_symbol_matches_domain (SYMBOL_DOMAIN (sym), domain))
76a01679 5910 {
c4d840bd
PH
5911 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5912 {
5913 if (SYMBOL_IS_ARGUMENT (sym))
5914 arg_sym = sym;
5915 else
2a2d4dc3 5916 {
c4d840bd
PH
5917 found_sym = 1;
5918 add_defn_to_vec (obstackp,
5919 fixup_symbol_section (sym, objfile),
5920 block);
2a2d4dc3 5921 }
c4d840bd 5922 }
76a01679
JB
5923 }
5924 }
96d887e8
PH
5925 }
5926
5927 if (!found_sym && arg_sym != NULL)
5928 {
76a01679
JB
5929 add_defn_to_vec (obstackp,
5930 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5931 block);
96d887e8
PH
5932 }
5933
5934 if (!wild)
5935 {
5936 arg_sym = NULL;
5937 found_sym = 0;
5938
5939 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 5940 {
b50c8614 5941 if (ada_symbol_matches_domain (SYMBOL_DOMAIN (sym), domain))
76a01679
JB
5942 {
5943 int cmp;
5944
5945 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5946 if (cmp == 0)
5947 {
5948 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5949 if (cmp == 0)
5950 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5951 name_len);
5952 }
5953
5954 if (cmp == 0
5955 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5956 {
2a2d4dc3
AS
5957 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5958 {
5959 if (SYMBOL_IS_ARGUMENT (sym))
5960 arg_sym = sym;
5961 else
5962 {
5963 found_sym = 1;
5964 add_defn_to_vec (obstackp,
5965 fixup_symbol_section (sym, objfile),
5966 block);
5967 }
5968 }
76a01679
JB
5969 }
5970 }
76a01679 5971 }
96d887e8
PH
5972
5973 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5974 They aren't parameters, right? */
5975 if (!found_sym && arg_sym != NULL)
5976 {
5977 add_defn_to_vec (obstackp,
76a01679 5978 fixup_symbol_section (arg_sym, objfile),
2570f2b7 5979 block);
96d887e8
PH
5980 }
5981 }
5982}
5983\f
41d27058
JB
5984
5985 /* Symbol Completion */
5986
5987/* If SYM_NAME is a completion candidate for TEXT, return this symbol
5988 name in a form that's appropriate for the completion. The result
5989 does not need to be deallocated, but is only good until the next call.
5990
5991 TEXT_LEN is equal to the length of TEXT.
e701b3c0 5992 Perform a wild match if WILD_MATCH_P is set.
6ea35997 5993 ENCODED_P should be set if TEXT represents the start of a symbol name
41d27058
JB
5994 in its encoded form. */
5995
5996static const char *
5997symbol_completion_match (const char *sym_name,
5998 const char *text, int text_len,
6ea35997 5999 int wild_match_p, int encoded_p)
41d27058 6000{
41d27058
JB
6001 const int verbatim_match = (text[0] == '<');
6002 int match = 0;
6003
6004 if (verbatim_match)
6005 {
6006 /* Strip the leading angle bracket. */
6007 text = text + 1;
6008 text_len--;
6009 }
6010
6011 /* First, test against the fully qualified name of the symbol. */
6012
6013 if (strncmp (sym_name, text, text_len) == 0)
6014 match = 1;
6015
6ea35997 6016 if (match && !encoded_p)
41d27058
JB
6017 {
6018 /* One needed check before declaring a positive match is to verify
6019 that iff we are doing a verbatim match, the decoded version
6020 of the symbol name starts with '<'. Otherwise, this symbol name
6021 is not a suitable completion. */
6022 const char *sym_name_copy = sym_name;
6023 int has_angle_bracket;
6024
6025 sym_name = ada_decode (sym_name);
6026 has_angle_bracket = (sym_name[0] == '<');
6027 match = (has_angle_bracket == verbatim_match);
6028 sym_name = sym_name_copy;
6029 }
6030
6031 if (match && !verbatim_match)
6032 {
6033 /* When doing non-verbatim match, another check that needs to
6034 be done is to verify that the potentially matching symbol name
6035 does not include capital letters, because the ada-mode would
6036 not be able to understand these symbol names without the
6037 angle bracket notation. */
6038 const char *tmp;
6039
6040 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6041 if (*tmp != '\0')
6042 match = 0;
6043 }
6044
6045 /* Second: Try wild matching... */
6046
e701b3c0 6047 if (!match && wild_match_p)
41d27058
JB
6048 {
6049 /* Since we are doing wild matching, this means that TEXT
6050 may represent an unqualified symbol name. We therefore must
6051 also compare TEXT against the unqualified name of the symbol. */
6052 sym_name = ada_unqualified_name (ada_decode (sym_name));
6053
6054 if (strncmp (sym_name, text, text_len) == 0)
6055 match = 1;
6056 }
6057
6058 /* Finally: If we found a mach, prepare the result to return. */
6059
6060 if (!match)
6061 return NULL;
6062
6063 if (verbatim_match)
6064 sym_name = add_angle_brackets (sym_name);
6065
6ea35997 6066 if (!encoded_p)
41d27058
JB
6067 sym_name = ada_decode (sym_name);
6068
6069 return sym_name;
6070}
6071
6072/* A companion function to ada_make_symbol_completion_list().
6073 Check if SYM_NAME represents a symbol which name would be suitable
6074 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
6075 it is appended at the end of the given string vector SV.
6076
6077 ORIG_TEXT is the string original string from the user command
6078 that needs to be completed. WORD is the entire command on which
6079 completion should be performed. These two parameters are used to
6080 determine which part of the symbol name should be added to the
6081 completion vector.
c0af1706 6082 if WILD_MATCH_P is set, then wild matching is performed.
cb8e9b97 6083 ENCODED_P should be set if TEXT represents a symbol name in its
41d27058
JB
6084 encoded formed (in which case the completion should also be
6085 encoded). */
6086
6087static void
d6565258 6088symbol_completion_add (VEC(char_ptr) **sv,
41d27058
JB
6089 const char *sym_name,
6090 const char *text, int text_len,
6091 const char *orig_text, const char *word,
cb8e9b97 6092 int wild_match_p, int encoded_p)
41d27058
JB
6093{
6094 const char *match = symbol_completion_match (sym_name, text, text_len,
cb8e9b97 6095 wild_match_p, encoded_p);
41d27058
JB
6096 char *completion;
6097
6098 if (match == NULL)
6099 return;
6100
6101 /* We found a match, so add the appropriate completion to the given
6102 string vector. */
6103
6104 if (word == orig_text)
6105 {
6106 completion = xmalloc (strlen (match) + 5);
6107 strcpy (completion, match);
6108 }
6109 else if (word > orig_text)
6110 {
6111 /* Return some portion of sym_name. */
6112 completion = xmalloc (strlen (match) + 5);
6113 strcpy (completion, match + (word - orig_text));
6114 }
6115 else
6116 {
6117 /* Return some of ORIG_TEXT plus sym_name. */
6118 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
6119 strncpy (completion, word, orig_text - word);
6120 completion[orig_text - word] = '\0';
6121 strcat (completion, match);
6122 }
6123
d6565258 6124 VEC_safe_push (char_ptr, *sv, completion);
41d27058
JB
6125}
6126
ccefe4c4 6127/* An object of this type is passed as the user_data argument to the
bb4142cf 6128 expand_symtabs_matching method. */
ccefe4c4
TT
6129struct add_partial_datum
6130{
6131 VEC(char_ptr) **completions;
6f937416 6132 const char *text;
ccefe4c4 6133 int text_len;
6f937416
PA
6134 const char *text0;
6135 const char *word;
ccefe4c4
TT
6136 int wild_match;
6137 int encoded;
6138};
6139
bb4142cf
DE
6140/* A callback for expand_symtabs_matching. */
6141
7b08b9eb 6142static int
bb4142cf 6143ada_complete_symbol_matcher (const char *name, void *user_data)
ccefe4c4
TT
6144{
6145 struct add_partial_datum *data = user_data;
7b08b9eb
JK
6146
6147 return symbol_completion_match (name, data->text, data->text_len,
6148 data->wild_match, data->encoded) != NULL;
ccefe4c4
TT
6149}
6150
49c4e619
TT
6151/* Return a list of possible symbol names completing TEXT0. WORD is
6152 the entire command on which completion is made. */
41d27058 6153
49c4e619 6154static VEC (char_ptr) *
6f937416
PA
6155ada_make_symbol_completion_list (const char *text0, const char *word,
6156 enum type_code code)
41d27058
JB
6157{
6158 char *text;
6159 int text_len;
b1ed564a
JB
6160 int wild_match_p;
6161 int encoded_p;
2ba95b9b 6162 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
41d27058
JB
6163 struct symbol *sym;
6164 struct symtab *s;
41d27058
JB
6165 struct minimal_symbol *msymbol;
6166 struct objfile *objfile;
6167 struct block *b, *surrounding_static_block = 0;
6168 int i;
8157b174 6169 struct block_iterator iter;
b8fea896 6170 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
41d27058 6171
2f68a895
TT
6172 gdb_assert (code == TYPE_CODE_UNDEF);
6173
41d27058
JB
6174 if (text0[0] == '<')
6175 {
6176 text = xstrdup (text0);
6177 make_cleanup (xfree, text);
6178 text_len = strlen (text);
b1ed564a
JB
6179 wild_match_p = 0;
6180 encoded_p = 1;
41d27058
JB
6181 }
6182 else
6183 {
6184 text = xstrdup (ada_encode (text0));
6185 make_cleanup (xfree, text);
6186 text_len = strlen (text);
6187 for (i = 0; i < text_len; i++)
6188 text[i] = tolower (text[i]);
6189
b1ed564a 6190 encoded_p = (strstr (text0, "__") != NULL);
41d27058
JB
6191 /* If the name contains a ".", then the user is entering a fully
6192 qualified entity name, and the match must not be done in wild
6193 mode. Similarly, if the user wants to complete what looks like
6194 an encoded name, the match must not be done in wild mode. */
b1ed564a 6195 wild_match_p = (strchr (text0, '.') == NULL && !encoded_p);
41d27058
JB
6196 }
6197
6198 /* First, look at the partial symtab symbols. */
41d27058 6199 {
ccefe4c4
TT
6200 struct add_partial_datum data;
6201
6202 data.completions = &completions;
6203 data.text = text;
6204 data.text_len = text_len;
6205 data.text0 = text0;
6206 data.word = word;
b1ed564a
JB
6207 data.wild_match = wild_match_p;
6208 data.encoded = encoded_p;
bb4142cf
DE
6209 expand_symtabs_matching (NULL, ada_complete_symbol_matcher, ALL_DOMAIN,
6210 &data);
41d27058
JB
6211 }
6212
6213 /* At this point scan through the misc symbol vectors and add each
6214 symbol you find to the list. Eventually we want to ignore
6215 anything that isn't a text symbol (everything else will be
6216 handled by the psymtab code above). */
6217
6218 ALL_MSYMBOLS (objfile, msymbol)
6219 {
6220 QUIT;
efd66ac6 6221 symbol_completion_add (&completions, MSYMBOL_LINKAGE_NAME (msymbol),
b1ed564a
JB
6222 text, text_len, text0, word, wild_match_p,
6223 encoded_p);
41d27058
JB
6224 }
6225
6226 /* Search upwards from currently selected frame (so that we can
6227 complete on local vars. */
6228
6229 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6230 {
6231 if (!BLOCK_SUPERBLOCK (b))
6232 surrounding_static_block = b; /* For elmin of dups */
6233
6234 ALL_BLOCK_SYMBOLS (b, iter, sym)
6235 {
d6565258 6236 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6237 text, text_len, text0, word,
b1ed564a 6238 wild_match_p, encoded_p);
41d27058
JB
6239 }
6240 }
6241
6242 /* Go through the symtabs and check the externs and statics for
6243 symbols which match. */
6244
6245 ALL_SYMTABS (objfile, s)
6246 {
6247 QUIT;
6248 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
6249 ALL_BLOCK_SYMBOLS (b, iter, sym)
6250 {
d6565258 6251 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6252 text, text_len, text0, word,
b1ed564a 6253 wild_match_p, encoded_p);
41d27058
JB
6254 }
6255 }
6256
6257 ALL_SYMTABS (objfile, s)
6258 {
6259 QUIT;
6260 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
6261 /* Don't do this block twice. */
6262 if (b == surrounding_static_block)
6263 continue;
6264 ALL_BLOCK_SYMBOLS (b, iter, sym)
6265 {
d6565258 6266 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6267 text, text_len, text0, word,
b1ed564a 6268 wild_match_p, encoded_p);
41d27058
JB
6269 }
6270 }
6271
b8fea896 6272 do_cleanups (old_chain);
49c4e619 6273 return completions;
41d27058
JB
6274}
6275
963a6417 6276 /* Field Access */
96d887e8 6277
73fb9985
JB
6278/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6279 for tagged types. */
6280
6281static int
6282ada_is_dispatch_table_ptr_type (struct type *type)
6283{
0d5cff50 6284 const char *name;
73fb9985
JB
6285
6286 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6287 return 0;
6288
6289 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6290 if (name == NULL)
6291 return 0;
6292
6293 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6294}
6295
ac4a2da4
JG
6296/* Return non-zero if TYPE is an interface tag. */
6297
6298static int
6299ada_is_interface_tag (struct type *type)
6300{
6301 const char *name = TYPE_NAME (type);
6302
6303 if (name == NULL)
6304 return 0;
6305
6306 return (strcmp (name, "ada__tags__interface_tag") == 0);
6307}
6308
963a6417
PH
6309/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6310 to be invisible to users. */
96d887e8 6311
963a6417
PH
6312int
6313ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6314{
963a6417
PH
6315 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6316 return 1;
ffde82bf 6317
73fb9985
JB
6318 /* Check the name of that field. */
6319 {
6320 const char *name = TYPE_FIELD_NAME (type, field_num);
6321
6322 /* Anonymous field names should not be printed.
6323 brobecker/2007-02-20: I don't think this can actually happen
6324 but we don't want to print the value of annonymous fields anyway. */
6325 if (name == NULL)
6326 return 1;
6327
ffde82bf
JB
6328 /* Normally, fields whose name start with an underscore ("_")
6329 are fields that have been internally generated by the compiler,
6330 and thus should not be printed. The "_parent" field is special,
6331 however: This is a field internally generated by the compiler
6332 for tagged types, and it contains the components inherited from
6333 the parent type. This field should not be printed as is, but
6334 should not be ignored either. */
73fb9985
JB
6335 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
6336 return 1;
6337 }
6338
ac4a2da4
JG
6339 /* If this is the dispatch table of a tagged type or an interface tag,
6340 then ignore. */
73fb9985 6341 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6342 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6343 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6344 return 1;
6345
6346 /* Not a special field, so it should not be ignored. */
6347 return 0;
963a6417 6348}
96d887e8 6349
963a6417 6350/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6351 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6352
963a6417
PH
6353int
6354ada_is_tagged_type (struct type *type, int refok)
6355{
6356 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
6357}
96d887e8 6358
963a6417 6359/* True iff TYPE represents the type of X'Tag */
96d887e8 6360
963a6417
PH
6361int
6362ada_is_tag_type (struct type *type)
6363{
6364 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6365 return 0;
6366 else
96d887e8 6367 {
963a6417 6368 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6369
963a6417
PH
6370 return (name != NULL
6371 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6372 }
96d887e8
PH
6373}
6374
963a6417 6375/* The type of the tag on VAL. */
76a01679 6376
963a6417
PH
6377struct type *
6378ada_tag_type (struct value *val)
96d887e8 6379{
df407dfe 6380 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
963a6417 6381}
96d887e8 6382
b50d69b5
JG
6383/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6384 retired at Ada 05). */
6385
6386static int
6387is_ada95_tag (struct value *tag)
6388{
6389 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6390}
6391
963a6417 6392/* The value of the tag on VAL. */
96d887e8 6393
963a6417
PH
6394struct value *
6395ada_value_tag (struct value *val)
6396{
03ee6b2e 6397 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6398}
6399
963a6417
PH
6400/* The value of the tag on the object of type TYPE whose contents are
6401 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6402 ADDRESS. */
96d887e8 6403
963a6417 6404static struct value *
10a2c479 6405value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6406 const gdb_byte *valaddr,
963a6417 6407 CORE_ADDR address)
96d887e8 6408{
b5385fc0 6409 int tag_byte_offset;
963a6417 6410 struct type *tag_type;
5b4ee69b 6411
963a6417 6412 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6413 NULL, NULL, NULL))
96d887e8 6414 {
fc1a4b47 6415 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6416 ? NULL
6417 : valaddr + tag_byte_offset);
963a6417 6418 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6419
963a6417 6420 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6421 }
963a6417
PH
6422 return NULL;
6423}
96d887e8 6424
963a6417
PH
6425static struct type *
6426type_from_tag (struct value *tag)
6427{
6428 const char *type_name = ada_tag_name (tag);
5b4ee69b 6429
963a6417
PH
6430 if (type_name != NULL)
6431 return ada_find_any_type (ada_encode (type_name));
6432 return NULL;
6433}
96d887e8 6434
b50d69b5
JG
6435/* Given a value OBJ of a tagged type, return a value of this
6436 type at the base address of the object. The base address, as
6437 defined in Ada.Tags, it is the address of the primary tag of
6438 the object, and therefore where the field values of its full
6439 view can be fetched. */
6440
6441struct value *
6442ada_tag_value_at_base_address (struct value *obj)
6443{
6444 volatile struct gdb_exception e;
6445 struct value *val;
6446 LONGEST offset_to_top = 0;
6447 struct type *ptr_type, *obj_type;
6448 struct value *tag;
6449 CORE_ADDR base_address;
6450
6451 obj_type = value_type (obj);
6452
6453 /* It is the responsability of the caller to deref pointers. */
6454
6455 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6456 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6457 return obj;
6458
6459 tag = ada_value_tag (obj);
6460 if (!tag)
6461 return obj;
6462
6463 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6464
6465 if (is_ada95_tag (tag))
6466 return obj;
6467
6468 ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
6469 ptr_type = lookup_pointer_type (ptr_type);
6470 val = value_cast (ptr_type, tag);
6471 if (!val)
6472 return obj;
6473
6474 /* It is perfectly possible that an exception be raised while
6475 trying to determine the base address, just like for the tag;
6476 see ada_tag_name for more details. We do not print the error
6477 message for the same reason. */
6478
6479 TRY_CATCH (e, RETURN_MASK_ERROR)
6480 {
6481 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6482 }
6483
6484 if (e.reason < 0)
6485 return obj;
6486
6487 /* If offset is null, nothing to do. */
6488
6489 if (offset_to_top == 0)
6490 return obj;
6491
6492 /* -1 is a special case in Ada.Tags; however, what should be done
6493 is not quite clear from the documentation. So do nothing for
6494 now. */
6495
6496 if (offset_to_top == -1)
6497 return obj;
6498
6499 base_address = value_address (obj) - offset_to_top;
6500 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6501
6502 /* Make sure that we have a proper tag at the new address.
6503 Otherwise, offset_to_top is bogus (which can happen when
6504 the object is not initialized yet). */
6505
6506 if (!tag)
6507 return obj;
6508
6509 obj_type = type_from_tag (tag);
6510
6511 if (!obj_type)
6512 return obj;
6513
6514 return value_from_contents_and_address (obj_type, NULL, base_address);
6515}
6516
1b611343
JB
6517/* Return the "ada__tags__type_specific_data" type. */
6518
6519static struct type *
6520ada_get_tsd_type (struct inferior *inf)
963a6417 6521{
1b611343 6522 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6523
1b611343
JB
6524 if (data->tsd_type == 0)
6525 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6526 return data->tsd_type;
6527}
529cad9c 6528
1b611343
JB
6529/* Return the TSD (type-specific data) associated to the given TAG.
6530 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6531
1b611343 6532 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6533
1b611343
JB
6534static struct value *
6535ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6536{
4c4b4cd2 6537 struct value *val;
1b611343 6538 struct type *type;
5b4ee69b 6539
1b611343
JB
6540 /* First option: The TSD is simply stored as a field of our TAG.
6541 Only older versions of GNAT would use this format, but we have
6542 to test it first, because there are no visible markers for
6543 the current approach except the absence of that field. */
529cad9c 6544
1b611343
JB
6545 val = ada_value_struct_elt (tag, "tsd", 1);
6546 if (val)
6547 return val;
e802dbe0 6548
1b611343
JB
6549 /* Try the second representation for the dispatch table (in which
6550 there is no explicit 'tsd' field in the referent of the tag pointer,
6551 and instead the tsd pointer is stored just before the dispatch
6552 table. */
e802dbe0 6553
1b611343
JB
6554 type = ada_get_tsd_type (current_inferior());
6555 if (type == NULL)
6556 return NULL;
6557 type = lookup_pointer_type (lookup_pointer_type (type));
6558 val = value_cast (type, tag);
6559 if (val == NULL)
6560 return NULL;
6561 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6562}
6563
1b611343
JB
6564/* Given the TSD of a tag (type-specific data), return a string
6565 containing the name of the associated type.
6566
6567 The returned value is good until the next call. May return NULL
6568 if we are unable to determine the tag name. */
6569
6570static char *
6571ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6572{
529cad9c
PH
6573 static char name[1024];
6574 char *p;
1b611343 6575 struct value *val;
529cad9c 6576
1b611343 6577 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6578 if (val == NULL)
1b611343 6579 return NULL;
4c4b4cd2
PH
6580 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6581 for (p = name; *p != '\0'; p += 1)
6582 if (isalpha (*p))
6583 *p = tolower (*p);
1b611343 6584 return name;
4c4b4cd2
PH
6585}
6586
6587/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6588 a C string.
6589
6590 Return NULL if the TAG is not an Ada tag, or if we were unable to
6591 determine the name of that tag. The result is good until the next
6592 call. */
4c4b4cd2
PH
6593
6594const char *
6595ada_tag_name (struct value *tag)
6596{
1b611343
JB
6597 volatile struct gdb_exception e;
6598 char *name = NULL;
5b4ee69b 6599
df407dfe 6600 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6601 return NULL;
1b611343
JB
6602
6603 /* It is perfectly possible that an exception be raised while trying
6604 to determine the TAG's name, even under normal circumstances:
6605 The associated variable may be uninitialized or corrupted, for
6606 instance. We do not let any exception propagate past this point.
6607 instead we return NULL.
6608
6609 We also do not print the error message either (which often is very
6610 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6611 the caller print a more meaningful message if necessary. */
6612 TRY_CATCH (e, RETURN_MASK_ERROR)
6613 {
6614 struct value *tsd = ada_get_tsd_from_tag (tag);
6615
6616 if (tsd != NULL)
6617 name = ada_tag_name_from_tsd (tsd);
6618 }
6619
6620 return name;
4c4b4cd2
PH
6621}
6622
6623/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6624
d2e4a39e 6625struct type *
ebf56fd3 6626ada_parent_type (struct type *type)
14f9c5c9
AS
6627{
6628 int i;
6629
61ee279c 6630 type = ada_check_typedef (type);
14f9c5c9
AS
6631
6632 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6633 return NULL;
6634
6635 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6636 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6637 {
6638 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6639
6640 /* If the _parent field is a pointer, then dereference it. */
6641 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6642 parent_type = TYPE_TARGET_TYPE (parent_type);
6643 /* If there is a parallel XVS type, get the actual base type. */
6644 parent_type = ada_get_base_type (parent_type);
6645
6646 return ada_check_typedef (parent_type);
6647 }
14f9c5c9
AS
6648
6649 return NULL;
6650}
6651
4c4b4cd2
PH
6652/* True iff field number FIELD_NUM of structure type TYPE contains the
6653 parent-type (inherited) fields of a derived type. Assumes TYPE is
6654 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6655
6656int
ebf56fd3 6657ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6658{
61ee279c 6659 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6660
4c4b4cd2
PH
6661 return (name != NULL
6662 && (strncmp (name, "PARENT", 6) == 0
6663 || strncmp (name, "_parent", 7) == 0));
14f9c5c9
AS
6664}
6665
4c4b4cd2 6666/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6667 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6668 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6669 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6670 structures. */
14f9c5c9
AS
6671
6672int
ebf56fd3 6673ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6674{
d2e4a39e 6675 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6676
d2e4a39e 6677 return (name != NULL
4c4b4cd2
PH
6678 && (strncmp (name, "PARENT", 6) == 0
6679 || strcmp (name, "REP") == 0
6680 || strncmp (name, "_parent", 7) == 0
6681 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6682}
6683
4c4b4cd2
PH
6684/* True iff field number FIELD_NUM of structure or union type TYPE
6685 is a variant wrapper. Assumes TYPE is a structure type with at least
6686 FIELD_NUM+1 fields. */
14f9c5c9
AS
6687
6688int
ebf56fd3 6689ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6690{
d2e4a39e 6691 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6692
14f9c5c9 6693 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6694 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6695 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6696 == TYPE_CODE_UNION)));
14f9c5c9
AS
6697}
6698
6699/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6700 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6701 returns the type of the controlling discriminant for the variant.
6702 May return NULL if the type could not be found. */
14f9c5c9 6703
d2e4a39e 6704struct type *
ebf56fd3 6705ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6706{
d2e4a39e 6707 char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6708
7c964f07 6709 return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
14f9c5c9
AS
6710}
6711
4c4b4cd2 6712/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6713 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6714 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6715
6716int
ebf56fd3 6717ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6718{
d2e4a39e 6719 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6720
14f9c5c9
AS
6721 return (name != NULL && name[0] == 'O');
6722}
6723
6724/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
6725 returns the name of the discriminant controlling the variant.
6726 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 6727
d2e4a39e 6728char *
ebf56fd3 6729ada_variant_discrim_name (struct type *type0)
14f9c5c9 6730{
d2e4a39e 6731 static char *result = NULL;
14f9c5c9 6732 static size_t result_len = 0;
d2e4a39e
AS
6733 struct type *type;
6734 const char *name;
6735 const char *discrim_end;
6736 const char *discrim_start;
14f9c5c9
AS
6737
6738 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6739 type = TYPE_TARGET_TYPE (type0);
6740 else
6741 type = type0;
6742
6743 name = ada_type_name (type);
6744
6745 if (name == NULL || name[0] == '\000')
6746 return "";
6747
6748 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6749 discrim_end -= 1)
6750 {
4c4b4cd2
PH
6751 if (strncmp (discrim_end, "___XVN", 6) == 0)
6752 break;
14f9c5c9
AS
6753 }
6754 if (discrim_end == name)
6755 return "";
6756
d2e4a39e 6757 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
6758 discrim_start -= 1)
6759 {
d2e4a39e 6760 if (discrim_start == name + 1)
4c4b4cd2 6761 return "";
76a01679 6762 if ((discrim_start > name + 3
4c4b4cd2
PH
6763 && strncmp (discrim_start - 3, "___", 3) == 0)
6764 || discrim_start[-1] == '.')
6765 break;
14f9c5c9
AS
6766 }
6767
6768 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6769 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 6770 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
6771 return result;
6772}
6773
4c4b4cd2
PH
6774/* Scan STR for a subtype-encoded number, beginning at position K.
6775 Put the position of the character just past the number scanned in
6776 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6777 Return 1 if there was a valid number at the given position, and 0
6778 otherwise. A "subtype-encoded" number consists of the absolute value
6779 in decimal, followed by the letter 'm' to indicate a negative number.
6780 Assumes 0m does not occur. */
14f9c5c9
AS
6781
6782int
d2e4a39e 6783ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
6784{
6785 ULONGEST RU;
6786
d2e4a39e 6787 if (!isdigit (str[k]))
14f9c5c9
AS
6788 return 0;
6789
4c4b4cd2 6790 /* Do it the hard way so as not to make any assumption about
14f9c5c9 6791 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 6792 LONGEST. */
14f9c5c9
AS
6793 RU = 0;
6794 while (isdigit (str[k]))
6795 {
d2e4a39e 6796 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
6797 k += 1;
6798 }
6799
d2e4a39e 6800 if (str[k] == 'm')
14f9c5c9
AS
6801 {
6802 if (R != NULL)
4c4b4cd2 6803 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
6804 k += 1;
6805 }
6806 else if (R != NULL)
6807 *R = (LONGEST) RU;
6808
4c4b4cd2 6809 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
6810 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6811 number representable as a LONGEST (although either would probably work
6812 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 6813 above is always equivalent to the negative of RU. */
14f9c5c9
AS
6814
6815 if (new_k != NULL)
6816 *new_k = k;
6817 return 1;
6818}
6819
4c4b4cd2
PH
6820/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6821 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6822 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 6823
d2e4a39e 6824int
ebf56fd3 6825ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 6826{
d2e4a39e 6827 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
6828 int p;
6829
6830 p = 0;
6831 while (1)
6832 {
d2e4a39e 6833 switch (name[p])
4c4b4cd2
PH
6834 {
6835 case '\0':
6836 return 0;
6837 case 'S':
6838 {
6839 LONGEST W;
5b4ee69b 6840
4c4b4cd2
PH
6841 if (!ada_scan_number (name, p + 1, &W, &p))
6842 return 0;
6843 if (val == W)
6844 return 1;
6845 break;
6846 }
6847 case 'R':
6848 {
6849 LONGEST L, U;
5b4ee69b 6850
4c4b4cd2
PH
6851 if (!ada_scan_number (name, p + 1, &L, &p)
6852 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6853 return 0;
6854 if (val >= L && val <= U)
6855 return 1;
6856 break;
6857 }
6858 case 'O':
6859 return 1;
6860 default:
6861 return 0;
6862 }
6863 }
6864}
6865
0963b4bd 6866/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
6867
6868/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6869 ARG_TYPE, extract and return the value of one of its (non-static)
6870 fields. FIELDNO says which field. Differs from value_primitive_field
6871 only in that it can handle packed values of arbitrary type. */
14f9c5c9 6872
4c4b4cd2 6873static struct value *
d2e4a39e 6874ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 6875 struct type *arg_type)
14f9c5c9 6876{
14f9c5c9
AS
6877 struct type *type;
6878
61ee279c 6879 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
6880 type = TYPE_FIELD_TYPE (arg_type, fieldno);
6881
4c4b4cd2 6882 /* Handle packed fields. */
14f9c5c9
AS
6883
6884 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
6885 {
6886 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6887 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 6888
0fd88904 6889 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
6890 offset + bit_pos / 8,
6891 bit_pos % 8, bit_size, type);
14f9c5c9
AS
6892 }
6893 else
6894 return value_primitive_field (arg1, offset, fieldno, arg_type);
6895}
6896
52ce6436
PH
6897/* Find field with name NAME in object of type TYPE. If found,
6898 set the following for each argument that is non-null:
6899 - *FIELD_TYPE_P to the field's type;
6900 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6901 an object of that type;
6902 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6903 - *BIT_SIZE_P to its size in bits if the field is packed, and
6904 0 otherwise;
6905 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6906 fields up to but not including the desired field, or by the total
6907 number of fields if not found. A NULL value of NAME never
6908 matches; the function just counts visible fields in this case.
6909
0963b4bd 6910 Returns 1 if found, 0 otherwise. */
52ce6436 6911
4c4b4cd2 6912static int
0d5cff50 6913find_struct_field (const char *name, struct type *type, int offset,
76a01679 6914 struct type **field_type_p,
52ce6436
PH
6915 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6916 int *index_p)
4c4b4cd2
PH
6917{
6918 int i;
6919
61ee279c 6920 type = ada_check_typedef (type);
76a01679 6921
52ce6436
PH
6922 if (field_type_p != NULL)
6923 *field_type_p = NULL;
6924 if (byte_offset_p != NULL)
d5d6fca5 6925 *byte_offset_p = 0;
52ce6436
PH
6926 if (bit_offset_p != NULL)
6927 *bit_offset_p = 0;
6928 if (bit_size_p != NULL)
6929 *bit_size_p = 0;
6930
6931 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
6932 {
6933 int bit_pos = TYPE_FIELD_BITPOS (type, i);
6934 int fld_offset = offset + bit_pos / 8;
0d5cff50 6935 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 6936
4c4b4cd2
PH
6937 if (t_field_name == NULL)
6938 continue;
6939
52ce6436 6940 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
6941 {
6942 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 6943
52ce6436
PH
6944 if (field_type_p != NULL)
6945 *field_type_p = TYPE_FIELD_TYPE (type, i);
6946 if (byte_offset_p != NULL)
6947 *byte_offset_p = fld_offset;
6948 if (bit_offset_p != NULL)
6949 *bit_offset_p = bit_pos % 8;
6950 if (bit_size_p != NULL)
6951 *bit_size_p = bit_size;
76a01679
JB
6952 return 1;
6953 }
4c4b4cd2
PH
6954 else if (ada_is_wrapper_field (type, i))
6955 {
52ce6436
PH
6956 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
6957 field_type_p, byte_offset_p, bit_offset_p,
6958 bit_size_p, index_p))
76a01679
JB
6959 return 1;
6960 }
4c4b4cd2
PH
6961 else if (ada_is_variant_part (type, i))
6962 {
52ce6436
PH
6963 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6964 fixed type?? */
4c4b4cd2 6965 int j;
52ce6436
PH
6966 struct type *field_type
6967 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 6968
52ce6436 6969 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 6970 {
76a01679
JB
6971 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
6972 fld_offset
6973 + TYPE_FIELD_BITPOS (field_type, j) / 8,
6974 field_type_p, byte_offset_p,
52ce6436 6975 bit_offset_p, bit_size_p, index_p))
76a01679 6976 return 1;
4c4b4cd2
PH
6977 }
6978 }
52ce6436
PH
6979 else if (index_p != NULL)
6980 *index_p += 1;
4c4b4cd2
PH
6981 }
6982 return 0;
6983}
6984
0963b4bd 6985/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 6986
52ce6436
PH
6987static int
6988num_visible_fields (struct type *type)
6989{
6990 int n;
5b4ee69b 6991
52ce6436
PH
6992 n = 0;
6993 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6994 return n;
6995}
14f9c5c9 6996
4c4b4cd2 6997/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
6998 and search in it assuming it has (class) type TYPE.
6999 If found, return value, else return NULL.
7000
4c4b4cd2 7001 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 7002
4c4b4cd2 7003static struct value *
d2e4a39e 7004ada_search_struct_field (char *name, struct value *arg, int offset,
4c4b4cd2 7005 struct type *type)
14f9c5c9
AS
7006{
7007 int i;
14f9c5c9 7008
5b4ee69b 7009 type = ada_check_typedef (type);
52ce6436 7010 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 7011 {
0d5cff50 7012 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7013
7014 if (t_field_name == NULL)
4c4b4cd2 7015 continue;
14f9c5c9
AS
7016
7017 else if (field_name_match (t_field_name, name))
4c4b4cd2 7018 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
7019
7020 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7021 {
0963b4bd 7022 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
7023 ada_search_struct_field (name, arg,
7024 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7025 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7026
4c4b4cd2
PH
7027 if (v != NULL)
7028 return v;
7029 }
14f9c5c9
AS
7030
7031 else if (ada_is_variant_part (type, i))
4c4b4cd2 7032 {
0963b4bd 7033 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 7034 int j;
5b4ee69b
MS
7035 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7036 i));
4c4b4cd2
PH
7037 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7038
52ce6436 7039 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7040 {
0963b4bd
MS
7041 struct value *v = ada_search_struct_field /* Force line
7042 break. */
06d5cf63
JB
7043 (name, arg,
7044 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7045 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 7046
4c4b4cd2
PH
7047 if (v != NULL)
7048 return v;
7049 }
7050 }
14f9c5c9
AS
7051 }
7052 return NULL;
7053}
d2e4a39e 7054
52ce6436
PH
7055static struct value *ada_index_struct_field_1 (int *, struct value *,
7056 int, struct type *);
7057
7058
7059/* Return field #INDEX in ARG, where the index is that returned by
7060 * find_struct_field through its INDEX_P argument. Adjust the address
7061 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 7062 * If found, return value, else return NULL. */
52ce6436
PH
7063
7064static struct value *
7065ada_index_struct_field (int index, struct value *arg, int offset,
7066 struct type *type)
7067{
7068 return ada_index_struct_field_1 (&index, arg, offset, type);
7069}
7070
7071
7072/* Auxiliary function for ada_index_struct_field. Like
7073 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 7074 * *INDEX_P. */
52ce6436
PH
7075
7076static struct value *
7077ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7078 struct type *type)
7079{
7080 int i;
7081 type = ada_check_typedef (type);
7082
7083 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7084 {
7085 if (TYPE_FIELD_NAME (type, i) == NULL)
7086 continue;
7087 else if (ada_is_wrapper_field (type, i))
7088 {
0963b4bd 7089 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
7090 ada_index_struct_field_1 (index_p, arg,
7091 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7092 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7093
52ce6436
PH
7094 if (v != NULL)
7095 return v;
7096 }
7097
7098 else if (ada_is_variant_part (type, i))
7099 {
7100 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 7101 find_struct_field. */
52ce6436
PH
7102 error (_("Cannot assign this kind of variant record"));
7103 }
7104 else if (*index_p == 0)
7105 return ada_value_primitive_field (arg, offset, i, type);
7106 else
7107 *index_p -= 1;
7108 }
7109 return NULL;
7110}
7111
4c4b4cd2
PH
7112/* Given ARG, a value of type (pointer or reference to a)*
7113 structure/union, extract the component named NAME from the ultimate
7114 target structure/union and return it as a value with its
f5938064 7115 appropriate type.
14f9c5c9 7116
4c4b4cd2
PH
7117 The routine searches for NAME among all members of the structure itself
7118 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7119 (e.g., '_parent').
7120
03ee6b2e
PH
7121 If NO_ERR, then simply return NULL in case of error, rather than
7122 calling error. */
14f9c5c9 7123
d2e4a39e 7124struct value *
03ee6b2e 7125ada_value_struct_elt (struct value *arg, char *name, int no_err)
14f9c5c9 7126{
4c4b4cd2 7127 struct type *t, *t1;
d2e4a39e 7128 struct value *v;
14f9c5c9 7129
4c4b4cd2 7130 v = NULL;
df407dfe 7131 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
7132 if (TYPE_CODE (t) == TYPE_CODE_REF)
7133 {
7134 t1 = TYPE_TARGET_TYPE (t);
7135 if (t1 == NULL)
03ee6b2e 7136 goto BadValue;
61ee279c 7137 t1 = ada_check_typedef (t1);
4c4b4cd2 7138 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 7139 {
994b9211 7140 arg = coerce_ref (arg);
76a01679
JB
7141 t = t1;
7142 }
4c4b4cd2 7143 }
14f9c5c9 7144
4c4b4cd2
PH
7145 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7146 {
7147 t1 = TYPE_TARGET_TYPE (t);
7148 if (t1 == NULL)
03ee6b2e 7149 goto BadValue;
61ee279c 7150 t1 = ada_check_typedef (t1);
4c4b4cd2 7151 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7152 {
7153 arg = value_ind (arg);
7154 t = t1;
7155 }
4c4b4cd2 7156 else
76a01679 7157 break;
4c4b4cd2 7158 }
14f9c5c9 7159
4c4b4cd2 7160 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 7161 goto BadValue;
14f9c5c9 7162
4c4b4cd2
PH
7163 if (t1 == t)
7164 v = ada_search_struct_field (name, arg, 0, t);
7165 else
7166 {
7167 int bit_offset, bit_size, byte_offset;
7168 struct type *field_type;
7169 CORE_ADDR address;
7170
76a01679 7171 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 7172 address = value_address (ada_value_ind (arg));
4c4b4cd2 7173 else
b50d69b5 7174 address = value_address (ada_coerce_ref (arg));
14f9c5c9 7175
1ed6ede0 7176 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
76a01679
JB
7177 if (find_struct_field (name, t1, 0,
7178 &field_type, &byte_offset, &bit_offset,
52ce6436 7179 &bit_size, NULL))
76a01679
JB
7180 {
7181 if (bit_size != 0)
7182 {
714e53ab
PH
7183 if (TYPE_CODE (t) == TYPE_CODE_REF)
7184 arg = ada_coerce_ref (arg);
7185 else
7186 arg = ada_value_ind (arg);
76a01679
JB
7187 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7188 bit_offset, bit_size,
7189 field_type);
7190 }
7191 else
f5938064 7192 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
7193 }
7194 }
7195
03ee6b2e
PH
7196 if (v != NULL || no_err)
7197 return v;
7198 else
323e0a4a 7199 error (_("There is no member named %s."), name);
14f9c5c9 7200
03ee6b2e
PH
7201 BadValue:
7202 if (no_err)
7203 return NULL;
7204 else
0963b4bd
MS
7205 error (_("Attempt to extract a component of "
7206 "a value that is not a record."));
14f9c5c9
AS
7207}
7208
7209/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7210 If DISPP is non-null, add its byte displacement from the beginning of a
7211 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7212 work for packed fields).
7213
7214 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7215 followed by "___".
14f9c5c9 7216
0963b4bd 7217 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
7218 be a (pointer or reference)+ to a struct or union, and the
7219 ultimate target type will be searched.
14f9c5c9
AS
7220
7221 Looks recursively into variant clauses and parent types.
7222
4c4b4cd2
PH
7223 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7224 TYPE is not a type of the right kind. */
14f9c5c9 7225
4c4b4cd2 7226static struct type *
76a01679
JB
7227ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
7228 int noerr, int *dispp)
14f9c5c9
AS
7229{
7230 int i;
7231
7232 if (name == NULL)
7233 goto BadName;
7234
76a01679 7235 if (refok && type != NULL)
4c4b4cd2
PH
7236 while (1)
7237 {
61ee279c 7238 type = ada_check_typedef (type);
76a01679
JB
7239 if (TYPE_CODE (type) != TYPE_CODE_PTR
7240 && TYPE_CODE (type) != TYPE_CODE_REF)
7241 break;
7242 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7243 }
14f9c5c9 7244
76a01679 7245 if (type == NULL
1265e4aa
JB
7246 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7247 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7248 {
4c4b4cd2 7249 if (noerr)
76a01679 7250 return NULL;
4c4b4cd2 7251 else
76a01679
JB
7252 {
7253 target_terminal_ours ();
7254 gdb_flush (gdb_stdout);
323e0a4a
AC
7255 if (type == NULL)
7256 error (_("Type (null) is not a structure or union type"));
7257 else
7258 {
7259 /* XXX: type_sprint */
7260 fprintf_unfiltered (gdb_stderr, _("Type "));
7261 type_print (type, "", gdb_stderr, -1);
7262 error (_(" is not a structure or union type"));
7263 }
76a01679 7264 }
14f9c5c9
AS
7265 }
7266
7267 type = to_static_fixed_type (type);
7268
7269 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7270 {
0d5cff50 7271 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7272 struct type *t;
7273 int disp;
d2e4a39e 7274
14f9c5c9 7275 if (t_field_name == NULL)
4c4b4cd2 7276 continue;
14f9c5c9
AS
7277
7278 else if (field_name_match (t_field_name, name))
4c4b4cd2
PH
7279 {
7280 if (dispp != NULL)
7281 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
61ee279c 7282 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7283 }
14f9c5c9
AS
7284
7285 else if (ada_is_wrapper_field (type, i))
4c4b4cd2
PH
7286 {
7287 disp = 0;
7288 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7289 0, 1, &disp);
7290 if (t != NULL)
7291 {
7292 if (dispp != NULL)
7293 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7294 return t;
7295 }
7296 }
14f9c5c9
AS
7297
7298 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7299 {
7300 int j;
5b4ee69b
MS
7301 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7302 i));
4c4b4cd2
PH
7303
7304 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7305 {
b1f33ddd
JB
7306 /* FIXME pnh 2008/01/26: We check for a field that is
7307 NOT wrapped in a struct, since the compiler sometimes
7308 generates these for unchecked variant types. Revisit
0963b4bd 7309 if the compiler changes this practice. */
0d5cff50 7310 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
4c4b4cd2 7311 disp = 0;
b1f33ddd
JB
7312 if (v_field_name != NULL
7313 && field_name_match (v_field_name, name))
7314 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
7315 else
0963b4bd
MS
7316 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7317 j),
b1f33ddd
JB
7318 name, 0, 1, &disp);
7319
4c4b4cd2
PH
7320 if (t != NULL)
7321 {
7322 if (dispp != NULL)
7323 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7324 return t;
7325 }
7326 }
7327 }
14f9c5c9
AS
7328
7329 }
7330
7331BadName:
d2e4a39e 7332 if (!noerr)
14f9c5c9
AS
7333 {
7334 target_terminal_ours ();
7335 gdb_flush (gdb_stdout);
323e0a4a
AC
7336 if (name == NULL)
7337 {
7338 /* XXX: type_sprint */
7339 fprintf_unfiltered (gdb_stderr, _("Type "));
7340 type_print (type, "", gdb_stderr, -1);
7341 error (_(" has no component named <null>"));
7342 }
7343 else
7344 {
7345 /* XXX: type_sprint */
7346 fprintf_unfiltered (gdb_stderr, _("Type "));
7347 type_print (type, "", gdb_stderr, -1);
7348 error (_(" has no component named %s"), name);
7349 }
14f9c5c9
AS
7350 }
7351
7352 return NULL;
7353}
7354
b1f33ddd
JB
7355/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7356 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7357 represents an unchecked union (that is, the variant part of a
0963b4bd 7358 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7359
7360static int
7361is_unchecked_variant (struct type *var_type, struct type *outer_type)
7362{
7363 char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7364
b1f33ddd
JB
7365 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
7366 == NULL);
7367}
7368
7369
14f9c5c9
AS
7370/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7371 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7372 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7373 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7374
d2e4a39e 7375int
ebf56fd3 7376ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7377 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7378{
7379 int others_clause;
7380 int i;
d2e4a39e 7381 char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7382 struct value *outer;
7383 struct value *discrim;
14f9c5c9
AS
7384 LONGEST discrim_val;
7385
0c281816
JB
7386 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
7387 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7388 if (discrim == NULL)
14f9c5c9 7389 return -1;
0c281816 7390 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7391
7392 others_clause = -1;
7393 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7394 {
7395 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7396 others_clause = i;
14f9c5c9 7397 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7398 return i;
14f9c5c9
AS
7399 }
7400
7401 return others_clause;
7402}
d2e4a39e 7403\f
14f9c5c9
AS
7404
7405
4c4b4cd2 7406 /* Dynamic-Sized Records */
14f9c5c9
AS
7407
7408/* Strategy: The type ostensibly attached to a value with dynamic size
7409 (i.e., a size that is not statically recorded in the debugging
7410 data) does not accurately reflect the size or layout of the value.
7411 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7412 conventional types that are constructed on the fly. */
14f9c5c9
AS
7413
7414/* There is a subtle and tricky problem here. In general, we cannot
7415 determine the size of dynamic records without its data. However,
7416 the 'struct value' data structure, which GDB uses to represent
7417 quantities in the inferior process (the target), requires the size
7418 of the type at the time of its allocation in order to reserve space
7419 for GDB's internal copy of the data. That's why the
7420 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7421 rather than struct value*s.
14f9c5c9
AS
7422
7423 However, GDB's internal history variables ($1, $2, etc.) are
7424 struct value*s containing internal copies of the data that are not, in
7425 general, the same as the data at their corresponding addresses in
7426 the target. Fortunately, the types we give to these values are all
7427 conventional, fixed-size types (as per the strategy described
7428 above), so that we don't usually have to perform the
7429 'to_fixed_xxx_type' conversions to look at their values.
7430 Unfortunately, there is one exception: if one of the internal
7431 history variables is an array whose elements are unconstrained
7432 records, then we will need to create distinct fixed types for each
7433 element selected. */
7434
7435/* The upshot of all of this is that many routines take a (type, host
7436 address, target address) triple as arguments to represent a value.
7437 The host address, if non-null, is supposed to contain an internal
7438 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7439 target at the target address. */
14f9c5c9
AS
7440
7441/* Assuming that VAL0 represents a pointer value, the result of
7442 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7443 dynamic-sized types. */
14f9c5c9 7444
d2e4a39e
AS
7445struct value *
7446ada_value_ind (struct value *val0)
14f9c5c9 7447{
c48db5ca 7448 struct value *val = value_ind (val0);
5b4ee69b 7449
b50d69b5
JG
7450 if (ada_is_tagged_type (value_type (val), 0))
7451 val = ada_tag_value_at_base_address (val);
7452
4c4b4cd2 7453 return ada_to_fixed_value (val);
14f9c5c9
AS
7454}
7455
7456/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7457 qualifiers on VAL0. */
7458
d2e4a39e
AS
7459static struct value *
7460ada_coerce_ref (struct value *val0)
7461{
df407dfe 7462 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7463 {
7464 struct value *val = val0;
5b4ee69b 7465
994b9211 7466 val = coerce_ref (val);
b50d69b5
JG
7467
7468 if (ada_is_tagged_type (value_type (val), 0))
7469 val = ada_tag_value_at_base_address (val);
7470
4c4b4cd2 7471 return ada_to_fixed_value (val);
d2e4a39e
AS
7472 }
7473 else
14f9c5c9
AS
7474 return val0;
7475}
7476
7477/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7478 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7479
7480static unsigned int
ebf56fd3 7481align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7482{
7483 return (off + alignment - 1) & ~(alignment - 1);
7484}
7485
4c4b4cd2 7486/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7487
7488static unsigned int
ebf56fd3 7489field_alignment (struct type *type, int f)
14f9c5c9 7490{
d2e4a39e 7491 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7492 int len;
14f9c5c9
AS
7493 int align_offset;
7494
64a1bf19
JB
7495 /* The field name should never be null, unless the debugging information
7496 is somehow malformed. In this case, we assume the field does not
7497 require any alignment. */
7498 if (name == NULL)
7499 return 1;
7500
7501 len = strlen (name);
7502
4c4b4cd2
PH
7503 if (!isdigit (name[len - 1]))
7504 return 1;
14f9c5c9 7505
d2e4a39e 7506 if (isdigit (name[len - 2]))
14f9c5c9
AS
7507 align_offset = len - 2;
7508 else
7509 align_offset = len - 1;
7510
4c4b4cd2 7511 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
14f9c5c9
AS
7512 return TARGET_CHAR_BIT;
7513
4c4b4cd2
PH
7514 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7515}
7516
852dff6c 7517/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7518
852dff6c
JB
7519static struct symbol *
7520ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7521{
7522 struct symbol *sym;
7523
7524 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
b50c8614
KS
7525 if (sym != NULL
7526 && (SYMBOL_DOMAIN (sym) != VAR_DOMAIN
7527 || SYMBOL_CLASS (sym) == LOC_TYPEDEF))
4c4b4cd2
PH
7528 return sym;
7529
b50c8614 7530 return NULL;
14f9c5c9
AS
7531}
7532
dddfab26
UW
7533/* Find a type named NAME. Ignores ambiguity. This routine will look
7534 solely for types defined by debug info, it will not search the GDB
7535 primitive types. */
4c4b4cd2 7536
852dff6c 7537static struct type *
ebf56fd3 7538ada_find_any_type (const char *name)
14f9c5c9 7539{
852dff6c 7540 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7541
14f9c5c9 7542 if (sym != NULL)
dddfab26 7543 return SYMBOL_TYPE (sym);
14f9c5c9 7544
dddfab26 7545 return NULL;
14f9c5c9
AS
7546}
7547
739593e0
JB
7548/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7549 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7550 symbol, in which case it is returned. Otherwise, this looks for
7551 symbols whose name is that of NAME_SYM suffixed with "___XR".
7552 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7553
7554struct symbol *
270140bd 7555ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7556{
739593e0 7557 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7558 struct symbol *sym;
7559
739593e0
JB
7560 if (strstr (name, "___XR") != NULL)
7561 return name_sym;
7562
aeb5907d
JB
7563 sym = find_old_style_renaming_symbol (name, block);
7564
7565 if (sym != NULL)
7566 return sym;
7567
0963b4bd 7568 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7569 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7570 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7571 return sym;
7572 else
7573 return NULL;
7574}
7575
7576static struct symbol *
270140bd 7577find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 7578{
7f0df278 7579 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
7580 char *rename;
7581
7582 if (function_sym != NULL)
7583 {
7584 /* If the symbol is defined inside a function, NAME is not fully
7585 qualified. This means we need to prepend the function name
7586 as well as adding the ``___XR'' suffix to build the name of
7587 the associated renaming symbol. */
0d5cff50 7588 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
7589 /* Function names sometimes contain suffixes used
7590 for instance to qualify nested subprograms. When building
7591 the XR type name, we need to make sure that this suffix is
7592 not included. So do not include any suffix in the function
7593 name length below. */
69fadcdf 7594 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
7595 const int rename_len = function_name_len + 2 /* "__" */
7596 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 7597
529cad9c 7598 /* Strip the suffix if necessary. */
69fadcdf
JB
7599 ada_remove_trailing_digits (function_name, &function_name_len);
7600 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7601 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 7602
4c4b4cd2
PH
7603 /* Library-level functions are a special case, as GNAT adds
7604 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 7605 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
7606 have this prefix, so we need to skip this prefix if present. */
7607 if (function_name_len > 5 /* "_ada_" */
7608 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
7609 {
7610 function_name += 5;
7611 function_name_len -= 5;
7612 }
4c4b4cd2
PH
7613
7614 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
7615 strncpy (rename, function_name, function_name_len);
7616 xsnprintf (rename + function_name_len, rename_len - function_name_len,
7617 "__%s___XR", name);
4c4b4cd2
PH
7618 }
7619 else
7620 {
7621 const int rename_len = strlen (name) + 6;
5b4ee69b 7622
4c4b4cd2 7623 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 7624 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
7625 }
7626
852dff6c 7627 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
7628}
7629
14f9c5c9 7630/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 7631 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 7632 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
7633 otherwise return 0. */
7634
14f9c5c9 7635int
d2e4a39e 7636ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
7637{
7638 if (type1 == NULL)
7639 return 1;
7640 else if (type0 == NULL)
7641 return 0;
7642 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7643 return 1;
7644 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7645 return 0;
4c4b4cd2
PH
7646 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7647 return 1;
ad82864c 7648 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 7649 return 1;
4c4b4cd2
PH
7650 else if (ada_is_array_descriptor_type (type0)
7651 && !ada_is_array_descriptor_type (type1))
14f9c5c9 7652 return 1;
aeb5907d
JB
7653 else
7654 {
7655 const char *type0_name = type_name_no_tag (type0);
7656 const char *type1_name = type_name_no_tag (type1);
7657
7658 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7659 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7660 return 1;
7661 }
14f9c5c9
AS
7662 return 0;
7663}
7664
7665/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
7666 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7667
0d5cff50 7668const char *
d2e4a39e 7669ada_type_name (struct type *type)
14f9c5c9 7670{
d2e4a39e 7671 if (type == NULL)
14f9c5c9
AS
7672 return NULL;
7673 else if (TYPE_NAME (type) != NULL)
7674 return TYPE_NAME (type);
7675 else
7676 return TYPE_TAG_NAME (type);
7677}
7678
b4ba55a1
JB
7679/* Search the list of "descriptive" types associated to TYPE for a type
7680 whose name is NAME. */
7681
7682static struct type *
7683find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7684{
7685 struct type *result;
7686
c6044dd1
JB
7687 if (ada_ignore_descriptive_types_p)
7688 return NULL;
7689
b4ba55a1
JB
7690 /* If there no descriptive-type info, then there is no parallel type
7691 to be found. */
7692 if (!HAVE_GNAT_AUX_INFO (type))
7693 return NULL;
7694
7695 result = TYPE_DESCRIPTIVE_TYPE (type);
7696 while (result != NULL)
7697 {
0d5cff50 7698 const char *result_name = ada_type_name (result);
b4ba55a1
JB
7699
7700 if (result_name == NULL)
7701 {
7702 warning (_("unexpected null name on descriptive type"));
7703 return NULL;
7704 }
7705
7706 /* If the names match, stop. */
7707 if (strcmp (result_name, name) == 0)
7708 break;
7709
7710 /* Otherwise, look at the next item on the list, if any. */
7711 if (HAVE_GNAT_AUX_INFO (result))
7712 result = TYPE_DESCRIPTIVE_TYPE (result);
7713 else
7714 result = NULL;
7715 }
7716
7717 /* If we didn't find a match, see whether this is a packed array. With
7718 older compilers, the descriptive type information is either absent or
7719 irrelevant when it comes to packed arrays so the above lookup fails.
7720 Fall back to using a parallel lookup by name in this case. */
12ab9e09 7721 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
7722 return ada_find_any_type (name);
7723
7724 return result;
7725}
7726
7727/* Find a parallel type to TYPE with the specified NAME, using the
7728 descriptive type taken from the debugging information, if available,
7729 and otherwise using the (slower) name-based method. */
7730
7731static struct type *
7732ada_find_parallel_type_with_name (struct type *type, const char *name)
7733{
7734 struct type *result = NULL;
7735
7736 if (HAVE_GNAT_AUX_INFO (type))
7737 result = find_parallel_type_by_descriptive_type (type, name);
7738 else
7739 result = ada_find_any_type (name);
7740
7741 return result;
7742}
7743
7744/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 7745 SUFFIX to the name of TYPE. */
14f9c5c9 7746
d2e4a39e 7747struct type *
ebf56fd3 7748ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 7749{
0d5cff50
DE
7750 char *name;
7751 const char *typename = ada_type_name (type);
14f9c5c9 7752 int len;
d2e4a39e 7753
14f9c5c9
AS
7754 if (typename == NULL)
7755 return NULL;
7756
7757 len = strlen (typename);
7758
b4ba55a1 7759 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9
AS
7760
7761 strcpy (name, typename);
7762 strcpy (name + len, suffix);
7763
b4ba55a1 7764 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
7765}
7766
14f9c5c9 7767/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 7768 type describing its fields. Otherwise, return NULL. */
14f9c5c9 7769
d2e4a39e
AS
7770static struct type *
7771dynamic_template_type (struct type *type)
14f9c5c9 7772{
61ee279c 7773 type = ada_check_typedef (type);
14f9c5c9
AS
7774
7775 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 7776 || ada_type_name (type) == NULL)
14f9c5c9 7777 return NULL;
d2e4a39e 7778 else
14f9c5c9
AS
7779 {
7780 int len = strlen (ada_type_name (type));
5b4ee69b 7781
4c4b4cd2
PH
7782 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7783 return type;
14f9c5c9 7784 else
4c4b4cd2 7785 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
7786 }
7787}
7788
7789/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 7790 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 7791
d2e4a39e
AS
7792static int
7793is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
7794{
7795 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 7796
d2e4a39e 7797 return name != NULL
14f9c5c9
AS
7798 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
7799 && strstr (name, "___XVL") != NULL;
7800}
7801
4c4b4cd2
PH
7802/* The index of the variant field of TYPE, or -1 if TYPE does not
7803 represent a variant record type. */
14f9c5c9 7804
d2e4a39e 7805static int
4c4b4cd2 7806variant_field_index (struct type *type)
14f9c5c9
AS
7807{
7808 int f;
7809
4c4b4cd2
PH
7810 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
7811 return -1;
7812
7813 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
7814 {
7815 if (ada_is_variant_part (type, f))
7816 return f;
7817 }
7818 return -1;
14f9c5c9
AS
7819}
7820
4c4b4cd2
PH
7821/* A record type with no fields. */
7822
d2e4a39e 7823static struct type *
e9bb382b 7824empty_record (struct type *template)
14f9c5c9 7825{
e9bb382b 7826 struct type *type = alloc_type_copy (template);
5b4ee69b 7827
14f9c5c9
AS
7828 TYPE_CODE (type) = TYPE_CODE_STRUCT;
7829 TYPE_NFIELDS (type) = 0;
7830 TYPE_FIELDS (type) = NULL;
b1f33ddd 7831 INIT_CPLUS_SPECIFIC (type);
14f9c5c9
AS
7832 TYPE_NAME (type) = "<empty>";
7833 TYPE_TAG_NAME (type) = NULL;
14f9c5c9
AS
7834 TYPE_LENGTH (type) = 0;
7835 return type;
7836}
7837
7838/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
7839 the value of type TYPE at VALADDR or ADDRESS (see comments at
7840 the beginning of this section) VAL according to GNAT conventions.
7841 DVAL0 should describe the (portion of a) record that contains any
df407dfe 7842 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
7843 an outer-level type (i.e., as opposed to a branch of a variant.) A
7844 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 7845 of the variant.
14f9c5c9 7846
4c4b4cd2
PH
7847 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7848 length are not statically known are discarded. As a consequence,
7849 VALADDR, ADDRESS and DVAL0 are ignored.
7850
7851 NOTE: Limitations: For now, we assume that dynamic fields and
7852 variants occupy whole numbers of bytes. However, they need not be
7853 byte-aligned. */
7854
7855struct type *
10a2c479 7856ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 7857 const gdb_byte *valaddr,
4c4b4cd2
PH
7858 CORE_ADDR address, struct value *dval0,
7859 int keep_dynamic_fields)
14f9c5c9 7860{
d2e4a39e
AS
7861 struct value *mark = value_mark ();
7862 struct value *dval;
7863 struct type *rtype;
14f9c5c9 7864 int nfields, bit_len;
4c4b4cd2 7865 int variant_field;
14f9c5c9 7866 long off;
d94e4f4f 7867 int fld_bit_len;
14f9c5c9
AS
7868 int f;
7869
4c4b4cd2
PH
7870 /* Compute the number of fields in this record type that are going
7871 to be processed: unless keep_dynamic_fields, this includes only
7872 fields whose position and length are static will be processed. */
7873 if (keep_dynamic_fields)
7874 nfields = TYPE_NFIELDS (type);
7875 else
7876 {
7877 nfields = 0;
76a01679 7878 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
7879 && !ada_is_variant_part (type, nfields)
7880 && !is_dynamic_field (type, nfields))
7881 nfields++;
7882 }
7883
e9bb382b 7884 rtype = alloc_type_copy (type);
14f9c5c9
AS
7885 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7886 INIT_CPLUS_SPECIFIC (rtype);
7887 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 7888 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
7889 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7890 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
7891 TYPE_NAME (rtype) = ada_type_name (type);
7892 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 7893 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 7894
d2e4a39e
AS
7895 off = 0;
7896 bit_len = 0;
4c4b4cd2
PH
7897 variant_field = -1;
7898
14f9c5c9
AS
7899 for (f = 0; f < nfields; f += 1)
7900 {
6c038f32
PH
7901 off = align_value (off, field_alignment (type, f))
7902 + TYPE_FIELD_BITPOS (type, f);
945b3a32 7903 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 7904 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 7905
d2e4a39e 7906 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
7907 {
7908 variant_field = f;
d94e4f4f 7909 fld_bit_len = 0;
4c4b4cd2 7910 }
14f9c5c9 7911 else if (is_dynamic_field (type, f))
4c4b4cd2 7912 {
284614f0
JB
7913 const gdb_byte *field_valaddr = valaddr;
7914 CORE_ADDR field_address = address;
7915 struct type *field_type =
7916 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
7917
4c4b4cd2 7918 if (dval0 == NULL)
b5304971
JG
7919 {
7920 /* rtype's length is computed based on the run-time
7921 value of discriminants. If the discriminants are not
7922 initialized, the type size may be completely bogus and
0963b4bd 7923 GDB may fail to allocate a value for it. So check the
b5304971
JG
7924 size first before creating the value. */
7925 check_size (rtype);
7926 dval = value_from_contents_and_address (rtype, valaddr, address);
9f1f738a 7927 rtype = value_type (dval);
b5304971 7928 }
4c4b4cd2
PH
7929 else
7930 dval = dval0;
7931
284614f0
JB
7932 /* If the type referenced by this field is an aligner type, we need
7933 to unwrap that aligner type, because its size might not be set.
7934 Keeping the aligner type would cause us to compute the wrong
7935 size for this field, impacting the offset of the all the fields
7936 that follow this one. */
7937 if (ada_is_aligner_type (field_type))
7938 {
7939 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
7940
7941 field_valaddr = cond_offset_host (field_valaddr, field_offset);
7942 field_address = cond_offset_target (field_address, field_offset);
7943 field_type = ada_aligned_type (field_type);
7944 }
7945
7946 field_valaddr = cond_offset_host (field_valaddr,
7947 off / TARGET_CHAR_BIT);
7948 field_address = cond_offset_target (field_address,
7949 off / TARGET_CHAR_BIT);
7950
7951 /* Get the fixed type of the field. Note that, in this case,
7952 we do not want to get the real type out of the tag: if
7953 the current field is the parent part of a tagged record,
7954 we will get the tag of the object. Clearly wrong: the real
7955 type of the parent is not the real type of the child. We
7956 would end up in an infinite loop. */
7957 field_type = ada_get_base_type (field_type);
7958 field_type = ada_to_fixed_type (field_type, field_valaddr,
7959 field_address, dval, 0);
27f2a97b
JB
7960 /* If the field size is already larger than the maximum
7961 object size, then the record itself will necessarily
7962 be larger than the maximum object size. We need to make
7963 this check now, because the size might be so ridiculously
7964 large (due to an uninitialized variable in the inferior)
7965 that it would cause an overflow when adding it to the
7966 record size. */
7967 check_size (field_type);
284614f0
JB
7968
7969 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 7970 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
7971 /* The multiplication can potentially overflow. But because
7972 the field length has been size-checked just above, and
7973 assuming that the maximum size is a reasonable value,
7974 an overflow should not happen in practice. So rather than
7975 adding overflow recovery code to this already complex code,
7976 we just assume that it's not going to happen. */
d94e4f4f 7977 fld_bit_len =
4c4b4cd2
PH
7978 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
7979 }
14f9c5c9 7980 else
4c4b4cd2 7981 {
5ded5331
JB
7982 /* Note: If this field's type is a typedef, it is important
7983 to preserve the typedef layer.
7984
7985 Otherwise, we might be transforming a typedef to a fat
7986 pointer (encoding a pointer to an unconstrained array),
7987 into a basic fat pointer (encoding an unconstrained
7988 array). As both types are implemented using the same
7989 structure, the typedef is the only clue which allows us
7990 to distinguish between the two options. Stripping it
7991 would prevent us from printing this field appropriately. */
7992 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
7993 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7994 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 7995 fld_bit_len =
4c4b4cd2
PH
7996 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7997 else
5ded5331
JB
7998 {
7999 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8000
8001 /* We need to be careful of typedefs when computing
8002 the length of our field. If this is a typedef,
8003 get the length of the target type, not the length
8004 of the typedef. */
8005 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8006 field_type = ada_typedef_target_type (field_type);
8007
8008 fld_bit_len =
8009 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8010 }
4c4b4cd2 8011 }
14f9c5c9 8012 if (off + fld_bit_len > bit_len)
4c4b4cd2 8013 bit_len = off + fld_bit_len;
d94e4f4f 8014 off += fld_bit_len;
4c4b4cd2
PH
8015 TYPE_LENGTH (rtype) =
8016 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 8017 }
4c4b4cd2
PH
8018
8019 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 8020 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
8021 the record. This can happen in the presence of representation
8022 clauses. */
8023 if (variant_field >= 0)
8024 {
8025 struct type *branch_type;
8026
8027 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8028
8029 if (dval0 == NULL)
9f1f738a
SA
8030 {
8031 dval = value_from_contents_and_address (rtype, valaddr, address);
8032 rtype = value_type (dval);
8033 }
4c4b4cd2
PH
8034 else
8035 dval = dval0;
8036
8037 branch_type =
8038 to_fixed_variant_branch_type
8039 (TYPE_FIELD_TYPE (type, variant_field),
8040 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8041 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8042 if (branch_type == NULL)
8043 {
8044 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8045 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8046 TYPE_NFIELDS (rtype) -= 1;
8047 }
8048 else
8049 {
8050 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8051 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8052 fld_bit_len =
8053 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8054 TARGET_CHAR_BIT;
8055 if (off + fld_bit_len > bit_len)
8056 bit_len = off + fld_bit_len;
8057 TYPE_LENGTH (rtype) =
8058 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8059 }
8060 }
8061
714e53ab
PH
8062 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8063 should contain the alignment of that record, which should be a strictly
8064 positive value. If null or negative, then something is wrong, most
8065 probably in the debug info. In that case, we don't round up the size
0963b4bd 8066 of the resulting type. If this record is not part of another structure,
714e53ab
PH
8067 the current RTYPE length might be good enough for our purposes. */
8068 if (TYPE_LENGTH (type) <= 0)
8069 {
323e0a4a
AC
8070 if (TYPE_NAME (rtype))
8071 warning (_("Invalid type size for `%s' detected: %d."),
8072 TYPE_NAME (rtype), TYPE_LENGTH (type));
8073 else
8074 warning (_("Invalid type size for <unnamed> detected: %d."),
8075 TYPE_LENGTH (type));
714e53ab
PH
8076 }
8077 else
8078 {
8079 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8080 TYPE_LENGTH (type));
8081 }
14f9c5c9
AS
8082
8083 value_free_to_mark (mark);
d2e4a39e 8084 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 8085 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8086 return rtype;
8087}
8088
4c4b4cd2
PH
8089/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8090 of 1. */
14f9c5c9 8091
d2e4a39e 8092static struct type *
fc1a4b47 8093template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
8094 CORE_ADDR address, struct value *dval0)
8095{
8096 return ada_template_to_fixed_record_type_1 (type, valaddr,
8097 address, dval0, 1);
8098}
8099
8100/* An ordinary record type in which ___XVL-convention fields and
8101 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8102 static approximations, containing all possible fields. Uses
8103 no runtime values. Useless for use in values, but that's OK,
8104 since the results are used only for type determinations. Works on both
8105 structs and unions. Representation note: to save space, we memorize
8106 the result of this function in the TYPE_TARGET_TYPE of the
8107 template type. */
8108
8109static struct type *
8110template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
8111{
8112 struct type *type;
8113 int nfields;
8114 int f;
8115
4c4b4cd2
PH
8116 if (TYPE_TARGET_TYPE (type0) != NULL)
8117 return TYPE_TARGET_TYPE (type0);
8118
8119 nfields = TYPE_NFIELDS (type0);
8120 type = type0;
14f9c5c9
AS
8121
8122 for (f = 0; f < nfields; f += 1)
8123 {
61ee279c 8124 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
4c4b4cd2 8125 struct type *new_type;
14f9c5c9 8126
4c4b4cd2
PH
8127 if (is_dynamic_field (type0, f))
8128 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
14f9c5c9 8129 else
f192137b 8130 new_type = static_unwrap_type (field_type);
4c4b4cd2
PH
8131 if (type == type0 && new_type != field_type)
8132 {
e9bb382b 8133 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
4c4b4cd2
PH
8134 TYPE_CODE (type) = TYPE_CODE (type0);
8135 INIT_CPLUS_SPECIFIC (type);
8136 TYPE_NFIELDS (type) = nfields;
8137 TYPE_FIELDS (type) = (struct field *)
8138 TYPE_ALLOC (type, nfields * sizeof (struct field));
8139 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8140 sizeof (struct field) * nfields);
8141 TYPE_NAME (type) = ada_type_name (type0);
8142 TYPE_TAG_NAME (type) = NULL;
876cecd0 8143 TYPE_FIXED_INSTANCE (type) = 1;
4c4b4cd2
PH
8144 TYPE_LENGTH (type) = 0;
8145 }
8146 TYPE_FIELD_TYPE (type, f) = new_type;
8147 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
14f9c5c9 8148 }
14f9c5c9
AS
8149 return type;
8150}
8151
4c4b4cd2 8152/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
8153 whose address in memory is ADDRESS, returns a revision of TYPE,
8154 which should be a non-dynamic-sized record, in which the variant
8155 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
8156 for discriminant values in DVAL0, which can be NULL if the record
8157 contains the necessary discriminant values. */
8158
d2e4a39e 8159static struct type *
fc1a4b47 8160to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 8161 CORE_ADDR address, struct value *dval0)
14f9c5c9 8162{
d2e4a39e 8163 struct value *mark = value_mark ();
4c4b4cd2 8164 struct value *dval;
d2e4a39e 8165 struct type *rtype;
14f9c5c9
AS
8166 struct type *branch_type;
8167 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 8168 int variant_field = variant_field_index (type);
14f9c5c9 8169
4c4b4cd2 8170 if (variant_field == -1)
14f9c5c9
AS
8171 return type;
8172
4c4b4cd2 8173 if (dval0 == NULL)
9f1f738a
SA
8174 {
8175 dval = value_from_contents_and_address (type, valaddr, address);
8176 type = value_type (dval);
8177 }
4c4b4cd2
PH
8178 else
8179 dval = dval0;
8180
e9bb382b 8181 rtype = alloc_type_copy (type);
14f9c5c9 8182 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
8183 INIT_CPLUS_SPECIFIC (rtype);
8184 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
8185 TYPE_FIELDS (rtype) =
8186 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8187 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 8188 sizeof (struct field) * nfields);
14f9c5c9
AS
8189 TYPE_NAME (rtype) = ada_type_name (type);
8190 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 8191 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
8192 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8193
4c4b4cd2
PH
8194 branch_type = to_fixed_variant_branch_type
8195 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 8196 cond_offset_host (valaddr,
4c4b4cd2
PH
8197 TYPE_FIELD_BITPOS (type, variant_field)
8198 / TARGET_CHAR_BIT),
d2e4a39e 8199 cond_offset_target (address,
4c4b4cd2
PH
8200 TYPE_FIELD_BITPOS (type, variant_field)
8201 / TARGET_CHAR_BIT), dval);
d2e4a39e 8202 if (branch_type == NULL)
14f9c5c9 8203 {
4c4b4cd2 8204 int f;
5b4ee69b 8205
4c4b4cd2
PH
8206 for (f = variant_field + 1; f < nfields; f += 1)
8207 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 8208 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
8209 }
8210 else
8211 {
4c4b4cd2
PH
8212 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8213 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8214 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 8215 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 8216 }
4c4b4cd2 8217 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 8218
4c4b4cd2 8219 value_free_to_mark (mark);
14f9c5c9
AS
8220 return rtype;
8221}
8222
8223/* An ordinary record type (with fixed-length fields) that describes
8224 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8225 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
8226 should be in DVAL, a record value; it may be NULL if the object
8227 at ADDR itself contains any necessary discriminant values.
8228 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8229 values from the record are needed. Except in the case that DVAL,
8230 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8231 unchecked) is replaced by a particular branch of the variant.
8232
8233 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8234 is questionable and may be removed. It can arise during the
8235 processing of an unconstrained-array-of-record type where all the
8236 variant branches have exactly the same size. This is because in
8237 such cases, the compiler does not bother to use the XVS convention
8238 when encoding the record. I am currently dubious of this
8239 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 8240
d2e4a39e 8241static struct type *
fc1a4b47 8242to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 8243 CORE_ADDR address, struct value *dval)
14f9c5c9 8244{
d2e4a39e 8245 struct type *templ_type;
14f9c5c9 8246
876cecd0 8247 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8248 return type0;
8249
d2e4a39e 8250 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
8251
8252 if (templ_type != NULL)
8253 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
8254 else if (variant_field_index (type0) >= 0)
8255 {
8256 if (dval == NULL && valaddr == NULL && address == 0)
8257 return type0;
8258 return to_record_with_fixed_variant_part (type0, valaddr, address,
8259 dval);
8260 }
14f9c5c9
AS
8261 else
8262 {
876cecd0 8263 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
8264 return type0;
8265 }
8266
8267}
8268
8269/* An ordinary record type (with fixed-length fields) that describes
8270 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8271 union type. Any necessary discriminants' values should be in DVAL,
8272 a record value. That is, this routine selects the appropriate
8273 branch of the union at ADDR according to the discriminant value
b1f33ddd 8274 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8275 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8276
d2e4a39e 8277static struct type *
fc1a4b47 8278to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8279 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8280{
8281 int which;
d2e4a39e
AS
8282 struct type *templ_type;
8283 struct type *var_type;
14f9c5c9
AS
8284
8285 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8286 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8287 else
14f9c5c9
AS
8288 var_type = var_type0;
8289
8290 templ_type = ada_find_parallel_type (var_type, "___XVU");
8291
8292 if (templ_type != NULL)
8293 var_type = templ_type;
8294
b1f33ddd
JB
8295 if (is_unchecked_variant (var_type, value_type (dval)))
8296 return var_type0;
d2e4a39e
AS
8297 which =
8298 ada_which_variant_applies (var_type,
0fd88904 8299 value_type (dval), value_contents (dval));
14f9c5c9
AS
8300
8301 if (which < 0)
e9bb382b 8302 return empty_record (var_type);
14f9c5c9 8303 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8304 return to_fixed_record_type
d2e4a39e
AS
8305 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8306 valaddr, address, dval);
4c4b4cd2 8307 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8308 return
8309 to_fixed_record_type
8310 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8311 else
8312 return TYPE_FIELD_TYPE (var_type, which);
8313}
8314
8315/* Assuming that TYPE0 is an array type describing the type of a value
8316 at ADDR, and that DVAL describes a record containing any
8317 discriminants used in TYPE0, returns a type for the value that
8318 contains no dynamic components (that is, no components whose sizes
8319 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8320 true, gives an error message if the resulting type's size is over
4c4b4cd2 8321 varsize_limit. */
14f9c5c9 8322
d2e4a39e
AS
8323static struct type *
8324to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8325 int ignore_too_big)
14f9c5c9 8326{
d2e4a39e
AS
8327 struct type *index_type_desc;
8328 struct type *result;
ad82864c 8329 int constrained_packed_array_p;
14f9c5c9 8330
b0dd7688 8331 type0 = ada_check_typedef (type0);
284614f0 8332 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8333 return type0;
14f9c5c9 8334
ad82864c
JB
8335 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8336 if (constrained_packed_array_p)
8337 type0 = decode_constrained_packed_array_type (type0);
284614f0 8338
14f9c5c9 8339 index_type_desc = ada_find_parallel_type (type0, "___XA");
28c85d6c 8340 ada_fixup_array_indexes_type (index_type_desc);
14f9c5c9
AS
8341 if (index_type_desc == NULL)
8342 {
61ee279c 8343 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8344
14f9c5c9 8345 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8346 depend on the contents of the array in properly constructed
8347 debugging data. */
529cad9c
PH
8348 /* Create a fixed version of the array element type.
8349 We're not providing the address of an element here,
e1d5a0d2 8350 and thus the actual object value cannot be inspected to do
529cad9c
PH
8351 the conversion. This should not be a problem, since arrays of
8352 unconstrained objects are not allowed. In particular, all
8353 the elements of an array of a tagged type should all be of
8354 the same type specified in the debugging info. No need to
8355 consult the object tag. */
1ed6ede0 8356 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8357
284614f0
JB
8358 /* Make sure we always create a new array type when dealing with
8359 packed array types, since we're going to fix-up the array
8360 type length and element bitsize a little further down. */
ad82864c 8361 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8362 result = type0;
14f9c5c9 8363 else
e9bb382b 8364 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8365 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8366 }
8367 else
8368 {
8369 int i;
8370 struct type *elt_type0;
8371
8372 elt_type0 = type0;
8373 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8374 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8375
8376 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8377 depend on the contents of the array in properly constructed
8378 debugging data. */
529cad9c
PH
8379 /* Create a fixed version of the array element type.
8380 We're not providing the address of an element here,
e1d5a0d2 8381 and thus the actual object value cannot be inspected to do
529cad9c
PH
8382 the conversion. This should not be a problem, since arrays of
8383 unconstrained objects are not allowed. In particular, all
8384 the elements of an array of a tagged type should all be of
8385 the same type specified in the debugging info. No need to
8386 consult the object tag. */
1ed6ede0
JB
8387 result =
8388 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8389
8390 elt_type0 = type0;
14f9c5c9 8391 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8392 {
8393 struct type *range_type =
28c85d6c 8394 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8395
e9bb382b 8396 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8397 result, range_type);
1ce677a4 8398 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8399 }
d2e4a39e 8400 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8401 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8402 }
8403
2e6fda7d
JB
8404 /* We want to preserve the type name. This can be useful when
8405 trying to get the type name of a value that has already been
8406 printed (for instance, if the user did "print VAR; whatis $". */
8407 TYPE_NAME (result) = TYPE_NAME (type0);
8408
ad82864c 8409 if (constrained_packed_array_p)
284614f0
JB
8410 {
8411 /* So far, the resulting type has been created as if the original
8412 type was a regular (non-packed) array type. As a result, the
8413 bitsize of the array elements needs to be set again, and the array
8414 length needs to be recomputed based on that bitsize. */
8415 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8416 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8417
8418 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8419 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8420 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8421 TYPE_LENGTH (result)++;
8422 }
8423
876cecd0 8424 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8425 return result;
d2e4a39e 8426}
14f9c5c9
AS
8427
8428
8429/* A standard type (containing no dynamically sized components)
8430 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8431 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8432 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8433 ADDRESS or in VALADDR contains these discriminants.
8434
1ed6ede0
JB
8435 If CHECK_TAG is not null, in the case of tagged types, this function
8436 attempts to locate the object's tag and use it to compute the actual
8437 type. However, when ADDRESS is null, we cannot use it to determine the
8438 location of the tag, and therefore compute the tagged type's actual type.
8439 So we return the tagged type without consulting the tag. */
529cad9c 8440
f192137b
JB
8441static struct type *
8442ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 8443 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 8444{
61ee279c 8445 type = ada_check_typedef (type);
d2e4a39e
AS
8446 switch (TYPE_CODE (type))
8447 {
8448 default:
14f9c5c9 8449 return type;
d2e4a39e 8450 case TYPE_CODE_STRUCT:
4c4b4cd2 8451 {
76a01679 8452 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
8453 struct type *fixed_record_type =
8454 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 8455
529cad9c
PH
8456 /* If STATIC_TYPE is a tagged type and we know the object's address,
8457 then we can determine its tag, and compute the object's actual
0963b4bd 8458 type from there. Note that we have to use the fixed record
1ed6ede0
JB
8459 type (the parent part of the record may have dynamic fields
8460 and the way the location of _tag is expressed may depend on
8461 them). */
529cad9c 8462
1ed6ede0 8463 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 8464 {
b50d69b5
JG
8465 struct value *tag =
8466 value_tag_from_contents_and_address
8467 (fixed_record_type,
8468 valaddr,
8469 address);
8470 struct type *real_type = type_from_tag (tag);
8471 struct value *obj =
8472 value_from_contents_and_address (fixed_record_type,
8473 valaddr,
8474 address);
9f1f738a 8475 fixed_record_type = value_type (obj);
76a01679 8476 if (real_type != NULL)
b50d69b5
JG
8477 return to_fixed_record_type
8478 (real_type, NULL,
8479 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 8480 }
4af88198
JB
8481
8482 /* Check to see if there is a parallel ___XVZ variable.
8483 If there is, then it provides the actual size of our type. */
8484 else if (ada_type_name (fixed_record_type) != NULL)
8485 {
0d5cff50 8486 const char *name = ada_type_name (fixed_record_type);
4af88198
JB
8487 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
8488 int xvz_found = 0;
8489 LONGEST size;
8490
88c15c34 8491 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
4af88198
JB
8492 size = get_int_var_value (xvz_name, &xvz_found);
8493 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8494 {
8495 fixed_record_type = copy_type (fixed_record_type);
8496 TYPE_LENGTH (fixed_record_type) = size;
8497
8498 /* The FIXED_RECORD_TYPE may have be a stub. We have
8499 observed this when the debugging info is STABS, and
8500 apparently it is something that is hard to fix.
8501
8502 In practice, we don't need the actual type definition
8503 at all, because the presence of the XVZ variable allows us
8504 to assume that there must be a XVS type as well, which we
8505 should be able to use later, when we need the actual type
8506 definition.
8507
8508 In the meantime, pretend that the "fixed" type we are
8509 returning is NOT a stub, because this can cause trouble
8510 when using this type to create new types targeting it.
8511 Indeed, the associated creation routines often check
8512 whether the target type is a stub and will try to replace
0963b4bd 8513 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
8514 might cause the new type to have the wrong size too.
8515 Consider the case of an array, for instance, where the size
8516 of the array is computed from the number of elements in
8517 our array multiplied by the size of its element. */
8518 TYPE_STUB (fixed_record_type) = 0;
8519 }
8520 }
1ed6ede0 8521 return fixed_record_type;
4c4b4cd2 8522 }
d2e4a39e 8523 case TYPE_CODE_ARRAY:
4c4b4cd2 8524 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
8525 case TYPE_CODE_UNION:
8526 if (dval == NULL)
4c4b4cd2 8527 return type;
d2e4a39e 8528 else
4c4b4cd2 8529 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 8530 }
14f9c5c9
AS
8531}
8532
f192137b
JB
8533/* The same as ada_to_fixed_type_1, except that it preserves the type
8534 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
8535
8536 The typedef layer needs be preserved in order to differentiate between
8537 arrays and array pointers when both types are implemented using the same
8538 fat pointer. In the array pointer case, the pointer is encoded as
8539 a typedef of the pointer type. For instance, considering:
8540
8541 type String_Access is access String;
8542 S1 : String_Access := null;
8543
8544 To the debugger, S1 is defined as a typedef of type String. But
8545 to the user, it is a pointer. So if the user tries to print S1,
8546 we should not dereference the array, but print the array address
8547 instead.
8548
8549 If we didn't preserve the typedef layer, we would lose the fact that
8550 the type is to be presented as a pointer (needs de-reference before
8551 being printed). And we would also use the source-level type name. */
f192137b
JB
8552
8553struct type *
8554ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8555 CORE_ADDR address, struct value *dval, int check_tag)
8556
8557{
8558 struct type *fixed_type =
8559 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8560
96dbd2c1
JB
8561 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8562 then preserve the typedef layer.
8563
8564 Implementation note: We can only check the main-type portion of
8565 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8566 from TYPE now returns a type that has the same instance flags
8567 as TYPE. For instance, if TYPE is a "typedef const", and its
8568 target type is a "struct", then the typedef elimination will return
8569 a "const" version of the target type. See check_typedef for more
8570 details about how the typedef layer elimination is done.
8571
8572 brobecker/2010-11-19: It seems to me that the only case where it is
8573 useful to preserve the typedef layer is when dealing with fat pointers.
8574 Perhaps, we could add a check for that and preserve the typedef layer
8575 only in that situation. But this seems unecessary so far, probably
8576 because we call check_typedef/ada_check_typedef pretty much everywhere.
8577 */
f192137b 8578 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 8579 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 8580 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
8581 return type;
8582
8583 return fixed_type;
8584}
8585
14f9c5c9 8586/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 8587 TYPE0, but based on no runtime data. */
14f9c5c9 8588
d2e4a39e
AS
8589static struct type *
8590to_static_fixed_type (struct type *type0)
14f9c5c9 8591{
d2e4a39e 8592 struct type *type;
14f9c5c9
AS
8593
8594 if (type0 == NULL)
8595 return NULL;
8596
876cecd0 8597 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8598 return type0;
8599
61ee279c 8600 type0 = ada_check_typedef (type0);
d2e4a39e 8601
14f9c5c9
AS
8602 switch (TYPE_CODE (type0))
8603 {
8604 default:
8605 return type0;
8606 case TYPE_CODE_STRUCT:
8607 type = dynamic_template_type (type0);
d2e4a39e 8608 if (type != NULL)
4c4b4cd2
PH
8609 return template_to_static_fixed_type (type);
8610 else
8611 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8612 case TYPE_CODE_UNION:
8613 type = ada_find_parallel_type (type0, "___XVU");
8614 if (type != NULL)
4c4b4cd2
PH
8615 return template_to_static_fixed_type (type);
8616 else
8617 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8618 }
8619}
8620
4c4b4cd2
PH
8621/* A static approximation of TYPE with all type wrappers removed. */
8622
d2e4a39e
AS
8623static struct type *
8624static_unwrap_type (struct type *type)
14f9c5c9
AS
8625{
8626 if (ada_is_aligner_type (type))
8627 {
61ee279c 8628 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 8629 if (ada_type_name (type1) == NULL)
4c4b4cd2 8630 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
8631
8632 return static_unwrap_type (type1);
8633 }
d2e4a39e 8634 else
14f9c5c9 8635 {
d2e4a39e 8636 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 8637
d2e4a39e 8638 if (raw_real_type == type)
4c4b4cd2 8639 return type;
14f9c5c9 8640 else
4c4b4cd2 8641 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
8642 }
8643}
8644
8645/* In some cases, incomplete and private types require
4c4b4cd2 8646 cross-references that are not resolved as records (for example,
14f9c5c9
AS
8647 type Foo;
8648 type FooP is access Foo;
8649 V: FooP;
8650 type Foo is array ...;
4c4b4cd2 8651 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
8652 cross-references to such types, we instead substitute for FooP a
8653 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 8654 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
8655
8656/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
8657 exists, otherwise TYPE. */
8658
d2e4a39e 8659struct type *
61ee279c 8660ada_check_typedef (struct type *type)
14f9c5c9 8661{
727e3d2e
JB
8662 if (type == NULL)
8663 return NULL;
8664
720d1a40
JB
8665 /* If our type is a typedef type of a fat pointer, then we're done.
8666 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8667 what allows us to distinguish between fat pointers that represent
8668 array types, and fat pointers that represent array access types
8669 (in both cases, the compiler implements them as fat pointers). */
8670 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8671 && is_thick_pntr (ada_typedef_target_type (type)))
8672 return type;
8673
14f9c5c9
AS
8674 CHECK_TYPEDEF (type);
8675 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 8676 || !TYPE_STUB (type)
14f9c5c9
AS
8677 || TYPE_TAG_NAME (type) == NULL)
8678 return type;
d2e4a39e 8679 else
14f9c5c9 8680 {
0d5cff50 8681 const char *name = TYPE_TAG_NAME (type);
d2e4a39e 8682 struct type *type1 = ada_find_any_type (name);
5b4ee69b 8683
05e522ef
JB
8684 if (type1 == NULL)
8685 return type;
8686
8687 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8688 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
8689 types, only for the typedef-to-array types). If that's the case,
8690 strip the typedef layer. */
8691 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
8692 type1 = ada_check_typedef (type1);
8693
8694 return type1;
14f9c5c9
AS
8695 }
8696}
8697
8698/* A value representing the data at VALADDR/ADDRESS as described by
8699 type TYPE0, but with a standard (static-sized) type that correctly
8700 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8701 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 8702 creation of struct values]. */
14f9c5c9 8703
4c4b4cd2
PH
8704static struct value *
8705ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8706 struct value *val0)
14f9c5c9 8707{
1ed6ede0 8708 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 8709
14f9c5c9
AS
8710 if (type == type0 && val0 != NULL)
8711 return val0;
d2e4a39e 8712 else
4c4b4cd2
PH
8713 return value_from_contents_and_address (type, 0, address);
8714}
8715
8716/* A value representing VAL, but with a standard (static-sized) type
8717 that correctly describes it. Does not necessarily create a new
8718 value. */
8719
0c3acc09 8720struct value *
4c4b4cd2
PH
8721ada_to_fixed_value (struct value *val)
8722{
c48db5ca
JB
8723 val = unwrap_value (val);
8724 val = ada_to_fixed_value_create (value_type (val),
8725 value_address (val),
8726 val);
8727 return val;
14f9c5c9 8728}
d2e4a39e 8729\f
14f9c5c9 8730
14f9c5c9
AS
8731/* Attributes */
8732
4c4b4cd2
PH
8733/* Table mapping attribute numbers to names.
8734 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 8735
d2e4a39e 8736static const char *attribute_names[] = {
14f9c5c9
AS
8737 "<?>",
8738
d2e4a39e 8739 "first",
14f9c5c9
AS
8740 "last",
8741 "length",
8742 "image",
14f9c5c9
AS
8743 "max",
8744 "min",
4c4b4cd2
PH
8745 "modulus",
8746 "pos",
8747 "size",
8748 "tag",
14f9c5c9 8749 "val",
14f9c5c9
AS
8750 0
8751};
8752
d2e4a39e 8753const char *
4c4b4cd2 8754ada_attribute_name (enum exp_opcode n)
14f9c5c9 8755{
4c4b4cd2
PH
8756 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8757 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
8758 else
8759 return attribute_names[0];
8760}
8761
4c4b4cd2 8762/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 8763
4c4b4cd2
PH
8764static LONGEST
8765pos_atr (struct value *arg)
14f9c5c9 8766{
24209737
PH
8767 struct value *val = coerce_ref (arg);
8768 struct type *type = value_type (val);
14f9c5c9 8769
d2e4a39e 8770 if (!discrete_type_p (type))
323e0a4a 8771 error (_("'POS only defined on discrete types"));
14f9c5c9
AS
8772
8773 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8774 {
8775 int i;
24209737 8776 LONGEST v = value_as_long (val);
14f9c5c9 8777
d2e4a39e 8778 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2 8779 {
14e75d8e 8780 if (v == TYPE_FIELD_ENUMVAL (type, i))
4c4b4cd2
PH
8781 return i;
8782 }
323e0a4a 8783 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9
AS
8784 }
8785 else
24209737 8786 return value_as_long (val);
4c4b4cd2
PH
8787}
8788
8789static struct value *
3cb382c9 8790value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 8791{
3cb382c9 8792 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
8793}
8794
4c4b4cd2 8795/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 8796
d2e4a39e
AS
8797static struct value *
8798value_val_atr (struct type *type, struct value *arg)
14f9c5c9 8799{
d2e4a39e 8800 if (!discrete_type_p (type))
323e0a4a 8801 error (_("'VAL only defined on discrete types"));
df407dfe 8802 if (!integer_type_p (value_type (arg)))
323e0a4a 8803 error (_("'VAL requires integral argument"));
14f9c5c9
AS
8804
8805 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8806 {
8807 long pos = value_as_long (arg);
5b4ee69b 8808
14f9c5c9 8809 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 8810 error (_("argument to 'VAL out of range"));
14e75d8e 8811 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
8812 }
8813 else
8814 return value_from_longest (type, value_as_long (arg));
8815}
14f9c5c9 8816\f
d2e4a39e 8817
4c4b4cd2 8818 /* Evaluation */
14f9c5c9 8819
4c4b4cd2
PH
8820/* True if TYPE appears to be an Ada character type.
8821 [At the moment, this is true only for Character and Wide_Character;
8822 It is a heuristic test that could stand improvement]. */
14f9c5c9 8823
d2e4a39e
AS
8824int
8825ada_is_character_type (struct type *type)
14f9c5c9 8826{
7b9f71f2
JB
8827 const char *name;
8828
8829 /* If the type code says it's a character, then assume it really is,
8830 and don't check any further. */
8831 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
8832 return 1;
8833
8834 /* Otherwise, assume it's a character type iff it is a discrete type
8835 with a known character type name. */
8836 name = ada_type_name (type);
8837 return (name != NULL
8838 && (TYPE_CODE (type) == TYPE_CODE_INT
8839 || TYPE_CODE (type) == TYPE_CODE_RANGE)
8840 && (strcmp (name, "character") == 0
8841 || strcmp (name, "wide_character") == 0
5a517ebd 8842 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 8843 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
8844}
8845
4c4b4cd2 8846/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
8847
8848int
ebf56fd3 8849ada_is_string_type (struct type *type)
14f9c5c9 8850{
61ee279c 8851 type = ada_check_typedef (type);
d2e4a39e 8852 if (type != NULL
14f9c5c9 8853 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
8854 && (ada_is_simple_array_type (type)
8855 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
8856 && ada_array_arity (type) == 1)
8857 {
8858 struct type *elttype = ada_array_element_type (type, 1);
8859
8860 return ada_is_character_type (elttype);
8861 }
d2e4a39e 8862 else
14f9c5c9
AS
8863 return 0;
8864}
8865
5bf03f13
JB
8866/* The compiler sometimes provides a parallel XVS type for a given
8867 PAD type. Normally, it is safe to follow the PAD type directly,
8868 but older versions of the compiler have a bug that causes the offset
8869 of its "F" field to be wrong. Following that field in that case
8870 would lead to incorrect results, but this can be worked around
8871 by ignoring the PAD type and using the associated XVS type instead.
8872
8873 Set to True if the debugger should trust the contents of PAD types.
8874 Otherwise, ignore the PAD type if there is a parallel XVS type. */
8875static int trust_pad_over_xvs = 1;
14f9c5c9
AS
8876
8877/* True if TYPE is a struct type introduced by the compiler to force the
8878 alignment of a value. Such types have a single field with a
4c4b4cd2 8879 distinctive name. */
14f9c5c9
AS
8880
8881int
ebf56fd3 8882ada_is_aligner_type (struct type *type)
14f9c5c9 8883{
61ee279c 8884 type = ada_check_typedef (type);
714e53ab 8885
5bf03f13 8886 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
8887 return 0;
8888
14f9c5c9 8889 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
8890 && TYPE_NFIELDS (type) == 1
8891 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
8892}
8893
8894/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 8895 the parallel type. */
14f9c5c9 8896
d2e4a39e
AS
8897struct type *
8898ada_get_base_type (struct type *raw_type)
14f9c5c9 8899{
d2e4a39e
AS
8900 struct type *real_type_namer;
8901 struct type *raw_real_type;
14f9c5c9
AS
8902
8903 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
8904 return raw_type;
8905
284614f0
JB
8906 if (ada_is_aligner_type (raw_type))
8907 /* The encoding specifies that we should always use the aligner type.
8908 So, even if this aligner type has an associated XVS type, we should
8909 simply ignore it.
8910
8911 According to the compiler gurus, an XVS type parallel to an aligner
8912 type may exist because of a stabs limitation. In stabs, aligner
8913 types are empty because the field has a variable-sized type, and
8914 thus cannot actually be used as an aligner type. As a result,
8915 we need the associated parallel XVS type to decode the type.
8916 Since the policy in the compiler is to not change the internal
8917 representation based on the debugging info format, we sometimes
8918 end up having a redundant XVS type parallel to the aligner type. */
8919 return raw_type;
8920
14f9c5c9 8921 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 8922 if (real_type_namer == NULL
14f9c5c9
AS
8923 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
8924 || TYPE_NFIELDS (real_type_namer) != 1)
8925 return raw_type;
8926
f80d3ff2
JB
8927 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
8928 {
8929 /* This is an older encoding form where the base type needs to be
8930 looked up by name. We prefer the newer enconding because it is
8931 more efficient. */
8932 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
8933 if (raw_real_type == NULL)
8934 return raw_type;
8935 else
8936 return raw_real_type;
8937 }
8938
8939 /* The field in our XVS type is a reference to the base type. */
8940 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 8941}
14f9c5c9 8942
4c4b4cd2 8943/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 8944
d2e4a39e
AS
8945struct type *
8946ada_aligned_type (struct type *type)
14f9c5c9
AS
8947{
8948 if (ada_is_aligner_type (type))
8949 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
8950 else
8951 return ada_get_base_type (type);
8952}
8953
8954
8955/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 8956 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 8957
fc1a4b47
AC
8958const gdb_byte *
8959ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 8960{
d2e4a39e 8961 if (ada_is_aligner_type (type))
14f9c5c9 8962 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
8963 valaddr +
8964 TYPE_FIELD_BITPOS (type,
8965 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
8966 else
8967 return valaddr;
8968}
8969
4c4b4cd2
PH
8970
8971
14f9c5c9 8972/* The printed representation of an enumeration literal with encoded
4c4b4cd2 8973 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
8974const char *
8975ada_enum_name (const char *name)
14f9c5c9 8976{
4c4b4cd2
PH
8977 static char *result;
8978 static size_t result_len = 0;
d2e4a39e 8979 char *tmp;
14f9c5c9 8980
4c4b4cd2
PH
8981 /* First, unqualify the enumeration name:
8982 1. Search for the last '.' character. If we find one, then skip
177b42fe 8983 all the preceding characters, the unqualified name starts
76a01679 8984 right after that dot.
4c4b4cd2 8985 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
8986 translates dots into "__". Search forward for double underscores,
8987 but stop searching when we hit an overloading suffix, which is
8988 of the form "__" followed by digits. */
4c4b4cd2 8989
c3e5cd34
PH
8990 tmp = strrchr (name, '.');
8991 if (tmp != NULL)
4c4b4cd2
PH
8992 name = tmp + 1;
8993 else
14f9c5c9 8994 {
4c4b4cd2
PH
8995 while ((tmp = strstr (name, "__")) != NULL)
8996 {
8997 if (isdigit (tmp[2]))
8998 break;
8999 else
9000 name = tmp + 2;
9001 }
14f9c5c9
AS
9002 }
9003
9004 if (name[0] == 'Q')
9005 {
14f9c5c9 9006 int v;
5b4ee69b 9007
14f9c5c9 9008 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
9009 {
9010 if (sscanf (name + 2, "%x", &v) != 1)
9011 return name;
9012 }
14f9c5c9 9013 else
4c4b4cd2 9014 return name;
14f9c5c9 9015
4c4b4cd2 9016 GROW_VECT (result, result_len, 16);
14f9c5c9 9017 if (isascii (v) && isprint (v))
88c15c34 9018 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 9019 else if (name[1] == 'U')
88c15c34 9020 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 9021 else
88c15c34 9022 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
9023
9024 return result;
9025 }
d2e4a39e 9026 else
4c4b4cd2 9027 {
c3e5cd34
PH
9028 tmp = strstr (name, "__");
9029 if (tmp == NULL)
9030 tmp = strstr (name, "$");
9031 if (tmp != NULL)
4c4b4cd2
PH
9032 {
9033 GROW_VECT (result, result_len, tmp - name + 1);
9034 strncpy (result, name, tmp - name);
9035 result[tmp - name] = '\0';
9036 return result;
9037 }
9038
9039 return name;
9040 }
14f9c5c9
AS
9041}
9042
14f9c5c9
AS
9043/* Evaluate the subexpression of EXP starting at *POS as for
9044 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 9045 expression. */
14f9c5c9 9046
d2e4a39e
AS
9047static struct value *
9048evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 9049{
4b27a620 9050 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
9051}
9052
9053/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 9054 value it wraps. */
14f9c5c9 9055
d2e4a39e
AS
9056static struct value *
9057unwrap_value (struct value *val)
14f9c5c9 9058{
df407dfe 9059 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 9060
14f9c5c9
AS
9061 if (ada_is_aligner_type (type))
9062 {
de4d072f 9063 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 9064 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 9065
14f9c5c9 9066 if (ada_type_name (val_type) == NULL)
4c4b4cd2 9067 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
9068
9069 return unwrap_value (v);
9070 }
d2e4a39e 9071 else
14f9c5c9 9072 {
d2e4a39e 9073 struct type *raw_real_type =
61ee279c 9074 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 9075
5bf03f13
JB
9076 /* If there is no parallel XVS or XVE type, then the value is
9077 already unwrapped. Return it without further modification. */
9078 if ((type == raw_real_type)
9079 && ada_find_parallel_type (type, "___XVE") == NULL)
9080 return val;
14f9c5c9 9081
d2e4a39e 9082 return
4c4b4cd2
PH
9083 coerce_unspec_val_to_type
9084 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 9085 value_address (val),
1ed6ede0 9086 NULL, 1));
14f9c5c9
AS
9087 }
9088}
d2e4a39e
AS
9089
9090static struct value *
9091cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
9092{
9093 LONGEST val;
9094
df407dfe 9095 if (type == value_type (arg))
14f9c5c9 9096 return arg;
df407dfe 9097 else if (ada_is_fixed_point_type (value_type (arg)))
d2e4a39e 9098 val = ada_float_to_fixed (type,
df407dfe 9099 ada_fixed_to_float (value_type (arg),
4c4b4cd2 9100 value_as_long (arg)));
d2e4a39e 9101 else
14f9c5c9 9102 {
a53b7a21 9103 DOUBLEST argd = value_as_double (arg);
5b4ee69b 9104
14f9c5c9
AS
9105 val = ada_float_to_fixed (type, argd);
9106 }
9107
9108 return value_from_longest (type, val);
9109}
9110
d2e4a39e 9111static struct value *
a53b7a21 9112cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 9113{
df407dfe 9114 DOUBLEST val = ada_fixed_to_float (value_type (arg),
4c4b4cd2 9115 value_as_long (arg));
5b4ee69b 9116
a53b7a21 9117 return value_from_double (type, val);
14f9c5c9
AS
9118}
9119
d99dcf51
JB
9120/* Given two array types T1 and T2, return nonzero iff both arrays
9121 contain the same number of elements. */
9122
9123static int
9124ada_same_array_size_p (struct type *t1, struct type *t2)
9125{
9126 LONGEST lo1, hi1, lo2, hi2;
9127
9128 /* Get the array bounds in order to verify that the size of
9129 the two arrays match. */
9130 if (!get_array_bounds (t1, &lo1, &hi1)
9131 || !get_array_bounds (t2, &lo2, &hi2))
9132 error (_("unable to determine array bounds"));
9133
9134 /* To make things easier for size comparison, normalize a bit
9135 the case of empty arrays by making sure that the difference
9136 between upper bound and lower bound is always -1. */
9137 if (lo1 > hi1)
9138 hi1 = lo1 - 1;
9139 if (lo2 > hi2)
9140 hi2 = lo2 - 1;
9141
9142 return (hi1 - lo1 == hi2 - lo2);
9143}
9144
9145/* Assuming that VAL is an array of integrals, and TYPE represents
9146 an array with the same number of elements, but with wider integral
9147 elements, return an array "casted" to TYPE. In practice, this
9148 means that the returned array is built by casting each element
9149 of the original array into TYPE's (wider) element type. */
9150
9151static struct value *
9152ada_promote_array_of_integrals (struct type *type, struct value *val)
9153{
9154 struct type *elt_type = TYPE_TARGET_TYPE (type);
9155 LONGEST lo, hi;
9156 struct value *res;
9157 LONGEST i;
9158
9159 /* Verify that both val and type are arrays of scalars, and
9160 that the size of val's elements is smaller than the size
9161 of type's element. */
9162 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9163 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9164 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9165 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9166 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9167 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9168
9169 if (!get_array_bounds (type, &lo, &hi))
9170 error (_("unable to determine array bounds"));
9171
9172 res = allocate_value (type);
9173
9174 /* Promote each array element. */
9175 for (i = 0; i < hi - lo + 1; i++)
9176 {
9177 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9178
9179 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9180 value_contents_all (elt), TYPE_LENGTH (elt_type));
9181 }
9182
9183 return res;
9184}
9185
4c4b4cd2
PH
9186/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9187 return the converted value. */
9188
d2e4a39e
AS
9189static struct value *
9190coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 9191{
df407dfe 9192 struct type *type2 = value_type (val);
5b4ee69b 9193
14f9c5c9
AS
9194 if (type == type2)
9195 return val;
9196
61ee279c
PH
9197 type2 = ada_check_typedef (type2);
9198 type = ada_check_typedef (type);
14f9c5c9 9199
d2e4a39e
AS
9200 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9201 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
9202 {
9203 val = ada_value_ind (val);
df407dfe 9204 type2 = value_type (val);
14f9c5c9
AS
9205 }
9206
d2e4a39e 9207 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
9208 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9209 {
d99dcf51
JB
9210 if (!ada_same_array_size_p (type, type2))
9211 error (_("cannot assign arrays of different length"));
9212
9213 if (is_integral_type (TYPE_TARGET_TYPE (type))
9214 && is_integral_type (TYPE_TARGET_TYPE (type2))
9215 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9216 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9217 {
9218 /* Allow implicit promotion of the array elements to
9219 a wider type. */
9220 return ada_promote_array_of_integrals (type, val);
9221 }
9222
9223 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9224 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 9225 error (_("Incompatible types in assignment"));
04624583 9226 deprecated_set_value_type (val, type);
14f9c5c9 9227 }
d2e4a39e 9228 return val;
14f9c5c9
AS
9229}
9230
4c4b4cd2
PH
9231static struct value *
9232ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9233{
9234 struct value *val;
9235 struct type *type1, *type2;
9236 LONGEST v, v1, v2;
9237
994b9211
AC
9238 arg1 = coerce_ref (arg1);
9239 arg2 = coerce_ref (arg2);
18af8284
JB
9240 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9241 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 9242
76a01679
JB
9243 if (TYPE_CODE (type1) != TYPE_CODE_INT
9244 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
9245 return value_binop (arg1, arg2, op);
9246
76a01679 9247 switch (op)
4c4b4cd2
PH
9248 {
9249 case BINOP_MOD:
9250 case BINOP_DIV:
9251 case BINOP_REM:
9252 break;
9253 default:
9254 return value_binop (arg1, arg2, op);
9255 }
9256
9257 v2 = value_as_long (arg2);
9258 if (v2 == 0)
323e0a4a 9259 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
9260
9261 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9262 return value_binop (arg1, arg2, op);
9263
9264 v1 = value_as_long (arg1);
9265 switch (op)
9266 {
9267 case BINOP_DIV:
9268 v = v1 / v2;
76a01679
JB
9269 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9270 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
9271 break;
9272 case BINOP_REM:
9273 v = v1 % v2;
76a01679
JB
9274 if (v * v1 < 0)
9275 v -= v2;
4c4b4cd2
PH
9276 break;
9277 default:
9278 /* Should not reach this point. */
9279 v = 0;
9280 }
9281
9282 val = allocate_value (type1);
990a07ab 9283 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9284 TYPE_LENGTH (value_type (val)),
9285 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9286 return val;
9287}
9288
9289static int
9290ada_value_equal (struct value *arg1, struct value *arg2)
9291{
df407dfe
AC
9292 if (ada_is_direct_array_type (value_type (arg1))
9293 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9294 {
f58b38bf
JB
9295 /* Automatically dereference any array reference before
9296 we attempt to perform the comparison. */
9297 arg1 = ada_coerce_ref (arg1);
9298 arg2 = ada_coerce_ref (arg2);
9299
4c4b4cd2
PH
9300 arg1 = ada_coerce_to_simple_array (arg1);
9301 arg2 = ada_coerce_to_simple_array (arg2);
df407dfe
AC
9302 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
9303 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
323e0a4a 9304 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9305 /* FIXME: The following works only for types whose
76a01679
JB
9306 representations use all bits (no padding or undefined bits)
9307 and do not have user-defined equality. */
9308 return
df407dfe 9309 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
0fd88904 9310 && memcmp (value_contents (arg1), value_contents (arg2),
df407dfe 9311 TYPE_LENGTH (value_type (arg1))) == 0;
4c4b4cd2
PH
9312 }
9313 return value_equal (arg1, arg2);
9314}
9315
52ce6436
PH
9316/* Total number of component associations in the aggregate starting at
9317 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9318 OP_AGGREGATE. */
52ce6436
PH
9319
9320static int
9321num_component_specs (struct expression *exp, int pc)
9322{
9323 int n, m, i;
5b4ee69b 9324
52ce6436
PH
9325 m = exp->elts[pc + 1].longconst;
9326 pc += 3;
9327 n = 0;
9328 for (i = 0; i < m; i += 1)
9329 {
9330 switch (exp->elts[pc].opcode)
9331 {
9332 default:
9333 n += 1;
9334 break;
9335 case OP_CHOICES:
9336 n += exp->elts[pc + 1].longconst;
9337 break;
9338 }
9339 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9340 }
9341 return n;
9342}
9343
9344/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9345 component of LHS (a simple array or a record), updating *POS past
9346 the expression, assuming that LHS is contained in CONTAINER. Does
9347 not modify the inferior's memory, nor does it modify LHS (unless
9348 LHS == CONTAINER). */
9349
9350static void
9351assign_component (struct value *container, struct value *lhs, LONGEST index,
9352 struct expression *exp, int *pos)
9353{
9354 struct value *mark = value_mark ();
9355 struct value *elt;
5b4ee69b 9356
52ce6436
PH
9357 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
9358 {
22601c15
UW
9359 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9360 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9361
52ce6436
PH
9362 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9363 }
9364 else
9365 {
9366 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9367 elt = ada_to_fixed_value (elt);
52ce6436
PH
9368 }
9369
9370 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9371 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9372 else
9373 value_assign_to_component (container, elt,
9374 ada_evaluate_subexp (NULL, exp, pos,
9375 EVAL_NORMAL));
9376
9377 value_free_to_mark (mark);
9378}
9379
9380/* Assuming that LHS represents an lvalue having a record or array
9381 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9382 of that aggregate's value to LHS, advancing *POS past the
9383 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9384 lvalue containing LHS (possibly LHS itself). Does not modify
9385 the inferior's memory, nor does it modify the contents of
0963b4bd 9386 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9387
9388static struct value *
9389assign_aggregate (struct value *container,
9390 struct value *lhs, struct expression *exp,
9391 int *pos, enum noside noside)
9392{
9393 struct type *lhs_type;
9394 int n = exp->elts[*pos+1].longconst;
9395 LONGEST low_index, high_index;
9396 int num_specs;
9397 LONGEST *indices;
9398 int max_indices, num_indices;
52ce6436 9399 int i;
52ce6436
PH
9400
9401 *pos += 3;
9402 if (noside != EVAL_NORMAL)
9403 {
52ce6436
PH
9404 for (i = 0; i < n; i += 1)
9405 ada_evaluate_subexp (NULL, exp, pos, noside);
9406 return container;
9407 }
9408
9409 container = ada_coerce_ref (container);
9410 if (ada_is_direct_array_type (value_type (container)))
9411 container = ada_coerce_to_simple_array (container);
9412 lhs = ada_coerce_ref (lhs);
9413 if (!deprecated_value_modifiable (lhs))
9414 error (_("Left operand of assignment is not a modifiable lvalue."));
9415
9416 lhs_type = value_type (lhs);
9417 if (ada_is_direct_array_type (lhs_type))
9418 {
9419 lhs = ada_coerce_to_simple_array (lhs);
9420 lhs_type = value_type (lhs);
9421 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9422 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
9423 }
9424 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9425 {
9426 low_index = 0;
9427 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
9428 }
9429 else
9430 error (_("Left-hand side must be array or record."));
9431
9432 num_specs = num_component_specs (exp, *pos - 3);
9433 max_indices = 4 * num_specs + 4;
9434 indices = alloca (max_indices * sizeof (indices[0]));
9435 indices[0] = indices[1] = low_index - 1;
9436 indices[2] = indices[3] = high_index + 1;
9437 num_indices = 4;
9438
9439 for (i = 0; i < n; i += 1)
9440 {
9441 switch (exp->elts[*pos].opcode)
9442 {
1fbf5ada
JB
9443 case OP_CHOICES:
9444 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9445 &num_indices, max_indices,
9446 low_index, high_index);
9447 break;
9448 case OP_POSITIONAL:
9449 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
9450 &num_indices, max_indices,
9451 low_index, high_index);
1fbf5ada
JB
9452 break;
9453 case OP_OTHERS:
9454 if (i != n-1)
9455 error (_("Misplaced 'others' clause"));
9456 aggregate_assign_others (container, lhs, exp, pos, indices,
9457 num_indices, low_index, high_index);
9458 break;
9459 default:
9460 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
9461 }
9462 }
9463
9464 return container;
9465}
9466
9467/* Assign into the component of LHS indexed by the OP_POSITIONAL
9468 construct at *POS, updating *POS past the construct, given that
9469 the positions are relative to lower bound LOW, where HIGH is the
9470 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9471 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 9472 assign_aggregate. */
52ce6436
PH
9473static void
9474aggregate_assign_positional (struct value *container,
9475 struct value *lhs, struct expression *exp,
9476 int *pos, LONGEST *indices, int *num_indices,
9477 int max_indices, LONGEST low, LONGEST high)
9478{
9479 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9480
9481 if (ind - 1 == high)
e1d5a0d2 9482 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
9483 if (ind <= high)
9484 {
9485 add_component_interval (ind, ind, indices, num_indices, max_indices);
9486 *pos += 3;
9487 assign_component (container, lhs, ind, exp, pos);
9488 }
9489 else
9490 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9491}
9492
9493/* Assign into the components of LHS indexed by the OP_CHOICES
9494 construct at *POS, updating *POS past the construct, given that
9495 the allowable indices are LOW..HIGH. Record the indices assigned
9496 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 9497 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9498static void
9499aggregate_assign_from_choices (struct value *container,
9500 struct value *lhs, struct expression *exp,
9501 int *pos, LONGEST *indices, int *num_indices,
9502 int max_indices, LONGEST low, LONGEST high)
9503{
9504 int j;
9505 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9506 int choice_pos, expr_pc;
9507 int is_array = ada_is_direct_array_type (value_type (lhs));
9508
9509 choice_pos = *pos += 3;
9510
9511 for (j = 0; j < n_choices; j += 1)
9512 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9513 expr_pc = *pos;
9514 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9515
9516 for (j = 0; j < n_choices; j += 1)
9517 {
9518 LONGEST lower, upper;
9519 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 9520
52ce6436
PH
9521 if (op == OP_DISCRETE_RANGE)
9522 {
9523 choice_pos += 1;
9524 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9525 EVAL_NORMAL));
9526 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9527 EVAL_NORMAL));
9528 }
9529 else if (is_array)
9530 {
9531 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9532 EVAL_NORMAL));
9533 upper = lower;
9534 }
9535 else
9536 {
9537 int ind;
0d5cff50 9538 const char *name;
5b4ee69b 9539
52ce6436
PH
9540 switch (op)
9541 {
9542 case OP_NAME:
9543 name = &exp->elts[choice_pos + 2].string;
9544 break;
9545 case OP_VAR_VALUE:
9546 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9547 break;
9548 default:
9549 error (_("Invalid record component association."));
9550 }
9551 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9552 ind = 0;
9553 if (! find_struct_field (name, value_type (lhs), 0,
9554 NULL, NULL, NULL, NULL, &ind))
9555 error (_("Unknown component name: %s."), name);
9556 lower = upper = ind;
9557 }
9558
9559 if (lower <= upper && (lower < low || upper > high))
9560 error (_("Index in component association out of bounds."));
9561
9562 add_component_interval (lower, upper, indices, num_indices,
9563 max_indices);
9564 while (lower <= upper)
9565 {
9566 int pos1;
5b4ee69b 9567
52ce6436
PH
9568 pos1 = expr_pc;
9569 assign_component (container, lhs, lower, exp, &pos1);
9570 lower += 1;
9571 }
9572 }
9573}
9574
9575/* Assign the value of the expression in the OP_OTHERS construct in
9576 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9577 have not been previously assigned. The index intervals already assigned
9578 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 9579 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9580static void
9581aggregate_assign_others (struct value *container,
9582 struct value *lhs, struct expression *exp,
9583 int *pos, LONGEST *indices, int num_indices,
9584 LONGEST low, LONGEST high)
9585{
9586 int i;
5ce64950 9587 int expr_pc = *pos + 1;
52ce6436
PH
9588
9589 for (i = 0; i < num_indices - 2; i += 2)
9590 {
9591 LONGEST ind;
5b4ee69b 9592
52ce6436
PH
9593 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9594 {
5ce64950 9595 int localpos;
5b4ee69b 9596
5ce64950
MS
9597 localpos = expr_pc;
9598 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
9599 }
9600 }
9601 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9602}
9603
9604/* Add the interval [LOW .. HIGH] to the sorted set of intervals
9605 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9606 modifying *SIZE as needed. It is an error if *SIZE exceeds
9607 MAX_SIZE. The resulting intervals do not overlap. */
9608static void
9609add_component_interval (LONGEST low, LONGEST high,
9610 LONGEST* indices, int *size, int max_size)
9611{
9612 int i, j;
5b4ee69b 9613
52ce6436
PH
9614 for (i = 0; i < *size; i += 2) {
9615 if (high >= indices[i] && low <= indices[i + 1])
9616 {
9617 int kh;
5b4ee69b 9618
52ce6436
PH
9619 for (kh = i + 2; kh < *size; kh += 2)
9620 if (high < indices[kh])
9621 break;
9622 if (low < indices[i])
9623 indices[i] = low;
9624 indices[i + 1] = indices[kh - 1];
9625 if (high > indices[i + 1])
9626 indices[i + 1] = high;
9627 memcpy (indices + i + 2, indices + kh, *size - kh);
9628 *size -= kh - i - 2;
9629 return;
9630 }
9631 else if (high < indices[i])
9632 break;
9633 }
9634
9635 if (*size == max_size)
9636 error (_("Internal error: miscounted aggregate components."));
9637 *size += 2;
9638 for (j = *size-1; j >= i+2; j -= 1)
9639 indices[j] = indices[j - 2];
9640 indices[i] = low;
9641 indices[i + 1] = high;
9642}
9643
6e48bd2c
JB
9644/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9645 is different. */
9646
9647static struct value *
9648ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
9649{
9650 if (type == ada_check_typedef (value_type (arg2)))
9651 return arg2;
9652
9653 if (ada_is_fixed_point_type (type))
9654 return (cast_to_fixed (type, arg2));
9655
9656 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9657 return cast_from_fixed (type, arg2);
6e48bd2c
JB
9658
9659 return value_cast (type, arg2);
9660}
9661
284614f0
JB
9662/* Evaluating Ada expressions, and printing their result.
9663 ------------------------------------------------------
9664
21649b50
JB
9665 1. Introduction:
9666 ----------------
9667
284614f0
JB
9668 We usually evaluate an Ada expression in order to print its value.
9669 We also evaluate an expression in order to print its type, which
9670 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9671 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9672 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9673 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9674 similar.
9675
9676 Evaluating expressions is a little more complicated for Ada entities
9677 than it is for entities in languages such as C. The main reason for
9678 this is that Ada provides types whose definition might be dynamic.
9679 One example of such types is variant records. Or another example
9680 would be an array whose bounds can only be known at run time.
9681
9682 The following description is a general guide as to what should be
9683 done (and what should NOT be done) in order to evaluate an expression
9684 involving such types, and when. This does not cover how the semantic
9685 information is encoded by GNAT as this is covered separatly. For the
9686 document used as the reference for the GNAT encoding, see exp_dbug.ads
9687 in the GNAT sources.
9688
9689 Ideally, we should embed each part of this description next to its
9690 associated code. Unfortunately, the amount of code is so vast right
9691 now that it's hard to see whether the code handling a particular
9692 situation might be duplicated or not. One day, when the code is
9693 cleaned up, this guide might become redundant with the comments
9694 inserted in the code, and we might want to remove it.
9695
21649b50
JB
9696 2. ``Fixing'' an Entity, the Simple Case:
9697 -----------------------------------------
9698
284614f0
JB
9699 When evaluating Ada expressions, the tricky issue is that they may
9700 reference entities whose type contents and size are not statically
9701 known. Consider for instance a variant record:
9702
9703 type Rec (Empty : Boolean := True) is record
9704 case Empty is
9705 when True => null;
9706 when False => Value : Integer;
9707 end case;
9708 end record;
9709 Yes : Rec := (Empty => False, Value => 1);
9710 No : Rec := (empty => True);
9711
9712 The size and contents of that record depends on the value of the
9713 descriminant (Rec.Empty). At this point, neither the debugging
9714 information nor the associated type structure in GDB are able to
9715 express such dynamic types. So what the debugger does is to create
9716 "fixed" versions of the type that applies to the specific object.
9717 We also informally refer to this opperation as "fixing" an object,
9718 which means creating its associated fixed type.
9719
9720 Example: when printing the value of variable "Yes" above, its fixed
9721 type would look like this:
9722
9723 type Rec is record
9724 Empty : Boolean;
9725 Value : Integer;
9726 end record;
9727
9728 On the other hand, if we printed the value of "No", its fixed type
9729 would become:
9730
9731 type Rec is record
9732 Empty : Boolean;
9733 end record;
9734
9735 Things become a little more complicated when trying to fix an entity
9736 with a dynamic type that directly contains another dynamic type,
9737 such as an array of variant records, for instance. There are
9738 two possible cases: Arrays, and records.
9739
21649b50
JB
9740 3. ``Fixing'' Arrays:
9741 ---------------------
9742
9743 The type structure in GDB describes an array in terms of its bounds,
9744 and the type of its elements. By design, all elements in the array
9745 have the same type and we cannot represent an array of variant elements
9746 using the current type structure in GDB. When fixing an array,
9747 we cannot fix the array element, as we would potentially need one
9748 fixed type per element of the array. As a result, the best we can do
9749 when fixing an array is to produce an array whose bounds and size
9750 are correct (allowing us to read it from memory), but without having
9751 touched its element type. Fixing each element will be done later,
9752 when (if) necessary.
9753
9754 Arrays are a little simpler to handle than records, because the same
9755 amount of memory is allocated for each element of the array, even if
1b536f04 9756 the amount of space actually used by each element differs from element
21649b50 9757 to element. Consider for instance the following array of type Rec:
284614f0
JB
9758
9759 type Rec_Array is array (1 .. 2) of Rec;
9760
1b536f04
JB
9761 The actual amount of memory occupied by each element might be different
9762 from element to element, depending on the value of their discriminant.
21649b50 9763 But the amount of space reserved for each element in the array remains
1b536f04 9764 fixed regardless. So we simply need to compute that size using
21649b50
JB
9765 the debugging information available, from which we can then determine
9766 the array size (we multiply the number of elements of the array by
9767 the size of each element).
9768
9769 The simplest case is when we have an array of a constrained element
9770 type. For instance, consider the following type declarations:
9771
9772 type Bounded_String (Max_Size : Integer) is
9773 Length : Integer;
9774 Buffer : String (1 .. Max_Size);
9775 end record;
9776 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9777
9778 In this case, the compiler describes the array as an array of
9779 variable-size elements (identified by its XVS suffix) for which
9780 the size can be read in the parallel XVZ variable.
9781
9782 In the case of an array of an unconstrained element type, the compiler
9783 wraps the array element inside a private PAD type. This type should not
9784 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
9785 that we also use the adjective "aligner" in our code to designate
9786 these wrapper types.
9787
1b536f04 9788 In some cases, the size allocated for each element is statically
21649b50
JB
9789 known. In that case, the PAD type already has the correct size,
9790 and the array element should remain unfixed.
9791
9792 But there are cases when this size is not statically known.
9793 For instance, assuming that "Five" is an integer variable:
284614f0
JB
9794
9795 type Dynamic is array (1 .. Five) of Integer;
9796 type Wrapper (Has_Length : Boolean := False) is record
9797 Data : Dynamic;
9798 case Has_Length is
9799 when True => Length : Integer;
9800 when False => null;
9801 end case;
9802 end record;
9803 type Wrapper_Array is array (1 .. 2) of Wrapper;
9804
9805 Hello : Wrapper_Array := (others => (Has_Length => True,
9806 Data => (others => 17),
9807 Length => 1));
9808
9809
9810 The debugging info would describe variable Hello as being an
9811 array of a PAD type. The size of that PAD type is not statically
9812 known, but can be determined using a parallel XVZ variable.
9813 In that case, a copy of the PAD type with the correct size should
9814 be used for the fixed array.
9815
21649b50
JB
9816 3. ``Fixing'' record type objects:
9817 ----------------------------------
9818
9819 Things are slightly different from arrays in the case of dynamic
284614f0
JB
9820 record types. In this case, in order to compute the associated
9821 fixed type, we need to determine the size and offset of each of
9822 its components. This, in turn, requires us to compute the fixed
9823 type of each of these components.
9824
9825 Consider for instance the example:
9826
9827 type Bounded_String (Max_Size : Natural) is record
9828 Str : String (1 .. Max_Size);
9829 Length : Natural;
9830 end record;
9831 My_String : Bounded_String (Max_Size => 10);
9832
9833 In that case, the position of field "Length" depends on the size
9834 of field Str, which itself depends on the value of the Max_Size
21649b50 9835 discriminant. In order to fix the type of variable My_String,
284614f0
JB
9836 we need to fix the type of field Str. Therefore, fixing a variant
9837 record requires us to fix each of its components.
9838
9839 However, if a component does not have a dynamic size, the component
9840 should not be fixed. In particular, fields that use a PAD type
9841 should not fixed. Here is an example where this might happen
9842 (assuming type Rec above):
9843
9844 type Container (Big : Boolean) is record
9845 First : Rec;
9846 After : Integer;
9847 case Big is
9848 when True => Another : Integer;
9849 when False => null;
9850 end case;
9851 end record;
9852 My_Container : Container := (Big => False,
9853 First => (Empty => True),
9854 After => 42);
9855
9856 In that example, the compiler creates a PAD type for component First,
9857 whose size is constant, and then positions the component After just
9858 right after it. The offset of component After is therefore constant
9859 in this case.
9860
9861 The debugger computes the position of each field based on an algorithm
9862 that uses, among other things, the actual position and size of the field
21649b50
JB
9863 preceding it. Let's now imagine that the user is trying to print
9864 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
9865 end up computing the offset of field After based on the size of the
9866 fixed version of field First. And since in our example First has
9867 only one actual field, the size of the fixed type is actually smaller
9868 than the amount of space allocated to that field, and thus we would
9869 compute the wrong offset of field After.
9870
21649b50
JB
9871 To make things more complicated, we need to watch out for dynamic
9872 components of variant records (identified by the ___XVL suffix in
9873 the component name). Even if the target type is a PAD type, the size
9874 of that type might not be statically known. So the PAD type needs
9875 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9876 we might end up with the wrong size for our component. This can be
9877 observed with the following type declarations:
284614f0
JB
9878
9879 type Octal is new Integer range 0 .. 7;
9880 type Octal_Array is array (Positive range <>) of Octal;
9881 pragma Pack (Octal_Array);
9882
9883 type Octal_Buffer (Size : Positive) is record
9884 Buffer : Octal_Array (1 .. Size);
9885 Length : Integer;
9886 end record;
9887
9888 In that case, Buffer is a PAD type whose size is unset and needs
9889 to be computed by fixing the unwrapped type.
9890
21649b50
JB
9891 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9892 ----------------------------------------------------------
9893
9894 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
9895 thus far, be actually fixed?
9896
9897 The answer is: Only when referencing that element. For instance
9898 when selecting one component of a record, this specific component
9899 should be fixed at that point in time. Or when printing the value
9900 of a record, each component should be fixed before its value gets
9901 printed. Similarly for arrays, the element of the array should be
9902 fixed when printing each element of the array, or when extracting
9903 one element out of that array. On the other hand, fixing should
9904 not be performed on the elements when taking a slice of an array!
9905
9906 Note that one of the side-effects of miscomputing the offset and
9907 size of each field is that we end up also miscomputing the size
9908 of the containing type. This can have adverse results when computing
9909 the value of an entity. GDB fetches the value of an entity based
9910 on the size of its type, and thus a wrong size causes GDB to fetch
9911 the wrong amount of memory. In the case where the computed size is
9912 too small, GDB fetches too little data to print the value of our
9913 entiry. Results in this case as unpredicatble, as we usually read
9914 past the buffer containing the data =:-o. */
9915
9916/* Implement the evaluate_exp routine in the exp_descriptor structure
9917 for the Ada language. */
9918
52ce6436 9919static struct value *
ebf56fd3 9920ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 9921 int *pos, enum noside noside)
14f9c5c9
AS
9922{
9923 enum exp_opcode op;
b5385fc0 9924 int tem;
14f9c5c9 9925 int pc;
5ec18f2b 9926 int preeval_pos;
14f9c5c9
AS
9927 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
9928 struct type *type;
52ce6436 9929 int nargs, oplen;
d2e4a39e 9930 struct value **argvec;
14f9c5c9 9931
d2e4a39e
AS
9932 pc = *pos;
9933 *pos += 1;
14f9c5c9
AS
9934 op = exp->elts[pc].opcode;
9935
d2e4a39e 9936 switch (op)
14f9c5c9
AS
9937 {
9938 default:
9939 *pos -= 1;
6e48bd2c 9940 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
9941
9942 if (noside == EVAL_NORMAL)
9943 arg1 = unwrap_value (arg1);
6e48bd2c
JB
9944
9945 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
9946 then we need to perform the conversion manually, because
9947 evaluate_subexp_standard doesn't do it. This conversion is
9948 necessary in Ada because the different kinds of float/fixed
9949 types in Ada have different representations.
9950
9951 Similarly, we need to perform the conversion from OP_LONG
9952 ourselves. */
9953 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
9954 arg1 = ada_value_cast (expect_type, arg1, noside);
9955
9956 return arg1;
4c4b4cd2
PH
9957
9958 case OP_STRING:
9959 {
76a01679 9960 struct value *result;
5b4ee69b 9961
76a01679
JB
9962 *pos -= 1;
9963 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
9964 /* The result type will have code OP_STRING, bashed there from
9965 OP_ARRAY. Bash it back. */
df407dfe
AC
9966 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
9967 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 9968 return result;
4c4b4cd2 9969 }
14f9c5c9
AS
9970
9971 case UNOP_CAST:
9972 (*pos) += 2;
9973 type = exp->elts[pc + 1].type;
9974 arg1 = evaluate_subexp (type, exp, pos, noside);
9975 if (noside == EVAL_SKIP)
4c4b4cd2 9976 goto nosideret;
6e48bd2c 9977 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
9978 return arg1;
9979
4c4b4cd2
PH
9980 case UNOP_QUAL:
9981 (*pos) += 2;
9982 type = exp->elts[pc + 1].type;
9983 return ada_evaluate_subexp (type, exp, pos, noside);
9984
14f9c5c9
AS
9985 case BINOP_ASSIGN:
9986 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
9987 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9988 {
9989 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
9990 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
9991 return arg1;
9992 return ada_value_assign (arg1, arg1);
9993 }
003f3813
JB
9994 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9995 except if the lhs of our assignment is a convenience variable.
9996 In the case of assigning to a convenience variable, the lhs
9997 should be exactly the result of the evaluation of the rhs. */
9998 type = value_type (arg1);
9999 if (VALUE_LVAL (arg1) == lval_internalvar)
10000 type = NULL;
10001 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 10002 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10003 return arg1;
df407dfe
AC
10004 if (ada_is_fixed_point_type (value_type (arg1)))
10005 arg2 = cast_to_fixed (value_type (arg1), arg2);
10006 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 10007 error
323e0a4a 10008 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 10009 else
df407dfe 10010 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 10011 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
10012
10013 case BINOP_ADD:
10014 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10015 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10016 if (noside == EVAL_SKIP)
4c4b4cd2 10017 goto nosideret;
2ac8a782
JB
10018 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10019 return (value_from_longest
10020 (value_type (arg1),
10021 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
10022 if ((ada_is_fixed_point_type (value_type (arg1))
10023 || ada_is_fixed_point_type (value_type (arg2)))
10024 && value_type (arg1) != value_type (arg2))
323e0a4a 10025 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
10026 /* Do the addition, and cast the result to the type of the first
10027 argument. We cannot cast the result to a reference type, so if
10028 ARG1 is a reference type, find its underlying type. */
10029 type = value_type (arg1);
10030 while (TYPE_CODE (type) == TYPE_CODE_REF)
10031 type = TYPE_TARGET_TYPE (type);
f44316fa 10032 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10033 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
10034
10035 case BINOP_SUB:
10036 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10037 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10038 if (noside == EVAL_SKIP)
4c4b4cd2 10039 goto nosideret;
2ac8a782
JB
10040 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10041 return (value_from_longest
10042 (value_type (arg1),
10043 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
10044 if ((ada_is_fixed_point_type (value_type (arg1))
10045 || ada_is_fixed_point_type (value_type (arg2)))
10046 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10047 error (_("Operands of fixed-point subtraction "
10048 "must have the same type"));
b7789565
JB
10049 /* Do the substraction, and cast the result to the type of the first
10050 argument. We cannot cast the result to a reference type, so if
10051 ARG1 is a reference type, find its underlying type. */
10052 type = value_type (arg1);
10053 while (TYPE_CODE (type) == TYPE_CODE_REF)
10054 type = TYPE_TARGET_TYPE (type);
f44316fa 10055 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10056 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10057
10058 case BINOP_MUL:
10059 case BINOP_DIV:
e1578042
JB
10060 case BINOP_REM:
10061 case BINOP_MOD:
14f9c5c9
AS
10062 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10063 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10064 if (noside == EVAL_SKIP)
4c4b4cd2 10065 goto nosideret;
e1578042 10066 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10067 {
10068 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10069 return value_zero (value_type (arg1), not_lval);
10070 }
14f9c5c9 10071 else
4c4b4cd2 10072 {
a53b7a21 10073 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10074 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10075 arg1 = cast_from_fixed (type, arg1);
df407dfe 10076 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10077 arg2 = cast_from_fixed (type, arg2);
f44316fa 10078 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10079 return ada_value_binop (arg1, arg2, op);
10080 }
10081
4c4b4cd2
PH
10082 case BINOP_EQUAL:
10083 case BINOP_NOTEQUAL:
14f9c5c9 10084 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10085 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10086 if (noside == EVAL_SKIP)
76a01679 10087 goto nosideret;
4c4b4cd2 10088 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10089 tem = 0;
4c4b4cd2 10090 else
f44316fa
UW
10091 {
10092 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10093 tem = ada_value_equal (arg1, arg2);
10094 }
4c4b4cd2 10095 if (op == BINOP_NOTEQUAL)
76a01679 10096 tem = !tem;
fbb06eb1
UW
10097 type = language_bool_type (exp->language_defn, exp->gdbarch);
10098 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10099
10100 case UNOP_NEG:
10101 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10102 if (noside == EVAL_SKIP)
10103 goto nosideret;
df407dfe
AC
10104 else if (ada_is_fixed_point_type (value_type (arg1)))
10105 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10106 else
f44316fa
UW
10107 {
10108 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10109 return value_neg (arg1);
10110 }
4c4b4cd2 10111
2330c6c6
JB
10112 case BINOP_LOGICAL_AND:
10113 case BINOP_LOGICAL_OR:
10114 case UNOP_LOGICAL_NOT:
000d5124
JB
10115 {
10116 struct value *val;
10117
10118 *pos -= 1;
10119 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10120 type = language_bool_type (exp->language_defn, exp->gdbarch);
10121 return value_cast (type, val);
000d5124 10122 }
2330c6c6
JB
10123
10124 case BINOP_BITWISE_AND:
10125 case BINOP_BITWISE_IOR:
10126 case BINOP_BITWISE_XOR:
000d5124
JB
10127 {
10128 struct value *val;
10129
10130 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10131 *pos = pc;
10132 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10133
10134 return value_cast (value_type (arg1), val);
10135 }
2330c6c6 10136
14f9c5c9
AS
10137 case OP_VAR_VALUE:
10138 *pos -= 1;
6799def4 10139
14f9c5c9 10140 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10141 {
10142 *pos += 4;
10143 goto nosideret;
10144 }
10145 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10146 /* Only encountered when an unresolved symbol occurs in a
10147 context other than a function call, in which case, it is
52ce6436 10148 invalid. */
323e0a4a 10149 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10150 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
14f9c5c9 10151 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10152 {
0c1f74cf 10153 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10154 /* Check to see if this is a tagged type. We also need to handle
10155 the case where the type is a reference to a tagged type, but
10156 we have to be careful to exclude pointers to tagged types.
10157 The latter should be shown as usual (as a pointer), whereas
10158 a reference should mostly be transparent to the user. */
10159 if (ada_is_tagged_type (type, 0)
023db19c 10160 || (TYPE_CODE (type) == TYPE_CODE_REF
31dbc1c5 10161 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0c1f74cf
JB
10162 {
10163 /* Tagged types are a little special in the fact that the real
10164 type is dynamic and can only be determined by inspecting the
10165 object's tag. This means that we need to get the object's
10166 value first (EVAL_NORMAL) and then extract the actual object
10167 type from its tag.
10168
10169 Note that we cannot skip the final step where we extract
10170 the object type from its tag, because the EVAL_NORMAL phase
10171 results in dynamic components being resolved into fixed ones.
10172 This can cause problems when trying to print the type
10173 description of tagged types whose parent has a dynamic size:
10174 We use the type name of the "_parent" component in order
10175 to print the name of the ancestor type in the type description.
10176 If that component had a dynamic size, the resolution into
10177 a fixed type would result in the loss of that type name,
10178 thus preventing us from printing the name of the ancestor
10179 type in the type description. */
10180 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
b50d69b5
JG
10181
10182 if (TYPE_CODE (type) != TYPE_CODE_REF)
10183 {
10184 struct type *actual_type;
10185
10186 actual_type = type_from_tag (ada_value_tag (arg1));
10187 if (actual_type == NULL)
10188 /* If, for some reason, we were unable to determine
10189 the actual type from the tag, then use the static
10190 approximation that we just computed as a fallback.
10191 This can happen if the debugging information is
10192 incomplete, for instance. */
10193 actual_type = type;
10194 return value_zero (actual_type, not_lval);
10195 }
10196 else
10197 {
10198 /* In the case of a ref, ada_coerce_ref takes care
10199 of determining the actual type. But the evaluation
10200 should return a ref as it should be valid to ask
10201 for its address; so rebuild a ref after coerce. */
10202 arg1 = ada_coerce_ref (arg1);
10203 return value_ref (arg1);
10204 }
0c1f74cf
JB
10205 }
10206
4c4b4cd2
PH
10207 *pos += 4;
10208 return value_zero
10209 (to_static_fixed_type
10210 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
10211 not_lval);
10212 }
d2e4a39e 10213 else
4c4b4cd2 10214 {
284614f0 10215 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
4c4b4cd2
PH
10216 return ada_to_fixed_value (arg1);
10217 }
10218
10219 case OP_FUNCALL:
10220 (*pos) += 2;
10221
10222 /* Allocate arg vector, including space for the function to be
10223 called in argvec[0] and a terminating NULL. */
10224 nargs = longest_to_int (exp->elts[pc + 1].longconst);
10225 argvec =
10226 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
10227
10228 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10229 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10230 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10231 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10232 else
10233 {
10234 for (tem = 0; tem <= nargs; tem += 1)
10235 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10236 argvec[tem] = 0;
10237
10238 if (noside == EVAL_SKIP)
10239 goto nosideret;
10240 }
10241
ad82864c
JB
10242 if (ada_is_constrained_packed_array_type
10243 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10244 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10245 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10246 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10247 /* This is a packed array that has already been fixed, and
10248 therefore already coerced to a simple array. Nothing further
10249 to do. */
10250 ;
df407dfe
AC
10251 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
10252 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
76a01679 10253 && VALUE_LVAL (argvec[0]) == lval_memory))
4c4b4cd2
PH
10254 argvec[0] = value_addr (argvec[0]);
10255
df407dfe 10256 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10257
10258 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10259 them. So, if this is an array typedef (encoding use for array
10260 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10261 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10262 type = ada_typedef_target_type (type);
10263
4c4b4cd2
PH
10264 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10265 {
61ee279c 10266 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10267 {
10268 case TYPE_CODE_FUNC:
61ee279c 10269 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10270 break;
10271 case TYPE_CODE_ARRAY:
10272 break;
10273 case TYPE_CODE_STRUCT:
10274 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10275 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10276 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10277 break;
10278 default:
323e0a4a 10279 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10280 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10281 break;
10282 }
10283 }
10284
10285 switch (TYPE_CODE (type))
10286 {
10287 case TYPE_CODE_FUNC:
10288 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972
PH
10289 {
10290 struct type *rtype = TYPE_TARGET_TYPE (type);
10291
10292 if (TYPE_GNU_IFUNC (type))
10293 return allocate_value (TYPE_TARGET_TYPE (rtype));
10294 return allocate_value (rtype);
10295 }
4c4b4cd2 10296 return call_function_by_hand (argvec[0], nargs, argvec + 1);
c8ea1972
PH
10297 case TYPE_CODE_INTERNAL_FUNCTION:
10298 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10299 /* We don't know anything about what the internal
10300 function might return, but we have to return
10301 something. */
10302 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10303 not_lval);
10304 else
10305 return call_internal_function (exp->gdbarch, exp->language_defn,
10306 argvec[0], nargs, argvec + 1);
10307
4c4b4cd2
PH
10308 case TYPE_CODE_STRUCT:
10309 {
10310 int arity;
10311
4c4b4cd2
PH
10312 arity = ada_array_arity (type);
10313 type = ada_array_element_type (type, nargs);
10314 if (type == NULL)
323e0a4a 10315 error (_("cannot subscript or call a record"));
4c4b4cd2 10316 if (arity != nargs)
323e0a4a 10317 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10318 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10319 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10320 return
10321 unwrap_value (ada_value_subscript
10322 (argvec[0], nargs, argvec + 1));
10323 }
10324 case TYPE_CODE_ARRAY:
10325 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10326 {
10327 type = ada_array_element_type (type, nargs);
10328 if (type == NULL)
323e0a4a 10329 error (_("element type of array unknown"));
4c4b4cd2 10330 else
0a07e705 10331 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10332 }
10333 return
10334 unwrap_value (ada_value_subscript
10335 (ada_coerce_to_simple_array (argvec[0]),
10336 nargs, argvec + 1));
10337 case TYPE_CODE_PTR: /* Pointer to array */
10338 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10339 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10340 {
10341 type = ada_array_element_type (type, nargs);
10342 if (type == NULL)
323e0a4a 10343 error (_("element type of array unknown"));
4c4b4cd2 10344 else
0a07e705 10345 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10346 }
10347 return
10348 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
10349 nargs, argvec + 1));
10350
10351 default:
e1d5a0d2
PH
10352 error (_("Attempt to index or call something other than an "
10353 "array or function"));
4c4b4cd2
PH
10354 }
10355
10356 case TERNOP_SLICE:
10357 {
10358 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10359 struct value *low_bound_val =
10360 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
10361 struct value *high_bound_val =
10362 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10363 LONGEST low_bound;
10364 LONGEST high_bound;
5b4ee69b 10365
994b9211
AC
10366 low_bound_val = coerce_ref (low_bound_val);
10367 high_bound_val = coerce_ref (high_bound_val);
714e53ab
PH
10368 low_bound = pos_atr (low_bound_val);
10369 high_bound = pos_atr (high_bound_val);
963a6417 10370
4c4b4cd2
PH
10371 if (noside == EVAL_SKIP)
10372 goto nosideret;
10373
4c4b4cd2
PH
10374 /* If this is a reference to an aligner type, then remove all
10375 the aligners. */
df407dfe
AC
10376 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10377 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10378 TYPE_TARGET_TYPE (value_type (array)) =
10379 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 10380
ad82864c 10381 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 10382 error (_("cannot slice a packed array"));
4c4b4cd2
PH
10383
10384 /* If this is a reference to an array or an array lvalue,
10385 convert to a pointer. */
df407dfe
AC
10386 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10387 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
10388 && VALUE_LVAL (array) == lval_memory))
10389 array = value_addr (array);
10390
1265e4aa 10391 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 10392 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 10393 (value_type (array))))
0b5d8877 10394 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
10395
10396 array = ada_coerce_to_simple_array_ptr (array);
10397
714e53ab
PH
10398 /* If we have more than one level of pointer indirection,
10399 dereference the value until we get only one level. */
df407dfe
AC
10400 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10401 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
10402 == TYPE_CODE_PTR))
10403 array = value_ind (array);
10404
10405 /* Make sure we really do have an array type before going further,
10406 to avoid a SEGV when trying to get the index type or the target
10407 type later down the road if the debug info generated by
10408 the compiler is incorrect or incomplete. */
df407dfe 10409 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 10410 error (_("cannot take slice of non-array"));
714e53ab 10411
828292f2
JB
10412 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10413 == TYPE_CODE_PTR)
4c4b4cd2 10414 {
828292f2
JB
10415 struct type *type0 = ada_check_typedef (value_type (array));
10416
0b5d8877 10417 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 10418 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
10419 else
10420 {
10421 struct type *arr_type0 =
828292f2 10422 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 10423
f5938064
JG
10424 return ada_value_slice_from_ptr (array, arr_type0,
10425 longest_to_int (low_bound),
10426 longest_to_int (high_bound));
4c4b4cd2
PH
10427 }
10428 }
10429 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10430 return array;
10431 else if (high_bound < low_bound)
df407dfe 10432 return empty_array (value_type (array), low_bound);
4c4b4cd2 10433 else
529cad9c
PH
10434 return ada_value_slice (array, longest_to_int (low_bound),
10435 longest_to_int (high_bound));
4c4b4cd2 10436 }
14f9c5c9 10437
4c4b4cd2
PH
10438 case UNOP_IN_RANGE:
10439 (*pos) += 2;
10440 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 10441 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 10442
14f9c5c9 10443 if (noside == EVAL_SKIP)
4c4b4cd2 10444 goto nosideret;
14f9c5c9 10445
4c4b4cd2
PH
10446 switch (TYPE_CODE (type))
10447 {
10448 default:
e1d5a0d2
PH
10449 lim_warning (_("Membership test incompletely implemented; "
10450 "always returns true"));
fbb06eb1
UW
10451 type = language_bool_type (exp->language_defn, exp->gdbarch);
10452 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
10453
10454 case TYPE_CODE_RANGE:
030b4912
UW
10455 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10456 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
10457 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10458 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
10459 type = language_bool_type (exp->language_defn, exp->gdbarch);
10460 return
10461 value_from_longest (type,
4c4b4cd2
PH
10462 (value_less (arg1, arg3)
10463 || value_equal (arg1, arg3))
10464 && (value_less (arg2, arg1)
10465 || value_equal (arg2, arg1)));
10466 }
10467
10468 case BINOP_IN_BOUNDS:
14f9c5c9 10469 (*pos) += 2;
4c4b4cd2
PH
10470 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10471 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10472
4c4b4cd2
PH
10473 if (noside == EVAL_SKIP)
10474 goto nosideret;
14f9c5c9 10475
4c4b4cd2 10476 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
10477 {
10478 type = language_bool_type (exp->language_defn, exp->gdbarch);
10479 return value_zero (type, not_lval);
10480 }
14f9c5c9 10481
4c4b4cd2 10482 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 10483
1eea4ebd
UW
10484 type = ada_index_type (value_type (arg2), tem, "range");
10485 if (!type)
10486 type = value_type (arg1);
14f9c5c9 10487
1eea4ebd
UW
10488 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10489 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 10490
f44316fa
UW
10491 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10492 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10493 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10494 return
fbb06eb1 10495 value_from_longest (type,
4c4b4cd2
PH
10496 (value_less (arg1, arg3)
10497 || value_equal (arg1, arg3))
10498 && (value_less (arg2, arg1)
10499 || value_equal (arg2, arg1)));
10500
10501 case TERNOP_IN_RANGE:
10502 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10503 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10504 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10505
10506 if (noside == EVAL_SKIP)
10507 goto nosideret;
10508
f44316fa
UW
10509 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10510 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10511 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10512 return
fbb06eb1 10513 value_from_longest (type,
4c4b4cd2
PH
10514 (value_less (arg1, arg3)
10515 || value_equal (arg1, arg3))
10516 && (value_less (arg2, arg1)
10517 || value_equal (arg2, arg1)));
10518
10519 case OP_ATR_FIRST:
10520 case OP_ATR_LAST:
10521 case OP_ATR_LENGTH:
10522 {
76a01679 10523 struct type *type_arg;
5b4ee69b 10524
76a01679
JB
10525 if (exp->elts[*pos].opcode == OP_TYPE)
10526 {
10527 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10528 arg1 = NULL;
5bc23cb3 10529 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
10530 }
10531 else
10532 {
10533 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10534 type_arg = NULL;
10535 }
10536
10537 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 10538 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
10539 tem = longest_to_int (exp->elts[*pos + 2].longconst);
10540 *pos += 4;
10541
10542 if (noside == EVAL_SKIP)
10543 goto nosideret;
10544
10545 if (type_arg == NULL)
10546 {
10547 arg1 = ada_coerce_ref (arg1);
10548
ad82864c 10549 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
10550 arg1 = ada_coerce_to_simple_array (arg1);
10551
aa4fb036 10552 if (op == OP_ATR_LENGTH)
1eea4ebd 10553 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
10554 else
10555 {
10556 type = ada_index_type (value_type (arg1), tem,
10557 ada_attribute_name (op));
10558 if (type == NULL)
10559 type = builtin_type (exp->gdbarch)->builtin_int;
10560 }
76a01679
JB
10561
10562 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 10563 return allocate_value (type);
76a01679
JB
10564
10565 switch (op)
10566 {
10567 default: /* Should never happen. */
323e0a4a 10568 error (_("unexpected attribute encountered"));
76a01679 10569 case OP_ATR_FIRST:
1eea4ebd
UW
10570 return value_from_longest
10571 (type, ada_array_bound (arg1, tem, 0));
76a01679 10572 case OP_ATR_LAST:
1eea4ebd
UW
10573 return value_from_longest
10574 (type, ada_array_bound (arg1, tem, 1));
76a01679 10575 case OP_ATR_LENGTH:
1eea4ebd
UW
10576 return value_from_longest
10577 (type, ada_array_length (arg1, tem));
76a01679
JB
10578 }
10579 }
10580 else if (discrete_type_p (type_arg))
10581 {
10582 struct type *range_type;
0d5cff50 10583 const char *name = ada_type_name (type_arg);
5b4ee69b 10584
76a01679
JB
10585 range_type = NULL;
10586 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 10587 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
10588 if (range_type == NULL)
10589 range_type = type_arg;
10590 switch (op)
10591 {
10592 default:
323e0a4a 10593 error (_("unexpected attribute encountered"));
76a01679 10594 case OP_ATR_FIRST:
690cc4eb 10595 return value_from_longest
43bbcdc2 10596 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 10597 case OP_ATR_LAST:
690cc4eb 10598 return value_from_longest
43bbcdc2 10599 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 10600 case OP_ATR_LENGTH:
323e0a4a 10601 error (_("the 'length attribute applies only to array types"));
76a01679
JB
10602 }
10603 }
10604 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 10605 error (_("unimplemented type attribute"));
76a01679
JB
10606 else
10607 {
10608 LONGEST low, high;
10609
ad82864c
JB
10610 if (ada_is_constrained_packed_array_type (type_arg))
10611 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 10612
aa4fb036 10613 if (op == OP_ATR_LENGTH)
1eea4ebd 10614 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
10615 else
10616 {
10617 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10618 if (type == NULL)
10619 type = builtin_type (exp->gdbarch)->builtin_int;
10620 }
1eea4ebd 10621
76a01679
JB
10622 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10623 return allocate_value (type);
10624
10625 switch (op)
10626 {
10627 default:
323e0a4a 10628 error (_("unexpected attribute encountered"));
76a01679 10629 case OP_ATR_FIRST:
1eea4ebd 10630 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
10631 return value_from_longest (type, low);
10632 case OP_ATR_LAST:
1eea4ebd 10633 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10634 return value_from_longest (type, high);
10635 case OP_ATR_LENGTH:
1eea4ebd
UW
10636 low = ada_array_bound_from_type (type_arg, tem, 0);
10637 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10638 return value_from_longest (type, high - low + 1);
10639 }
10640 }
14f9c5c9
AS
10641 }
10642
4c4b4cd2
PH
10643 case OP_ATR_TAG:
10644 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10645 if (noside == EVAL_SKIP)
76a01679 10646 goto nosideret;
4c4b4cd2
PH
10647
10648 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10649 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
10650
10651 return ada_value_tag (arg1);
10652
10653 case OP_ATR_MIN:
10654 case OP_ATR_MAX:
10655 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10656 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10657 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10658 if (noside == EVAL_SKIP)
76a01679 10659 goto nosideret;
d2e4a39e 10660 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10661 return value_zero (value_type (arg1), not_lval);
14f9c5c9 10662 else
f44316fa
UW
10663 {
10664 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10665 return value_binop (arg1, arg2,
10666 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
10667 }
14f9c5c9 10668
4c4b4cd2
PH
10669 case OP_ATR_MODULUS:
10670 {
31dedfee 10671 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 10672
5b4ee69b 10673 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
10674 if (noside == EVAL_SKIP)
10675 goto nosideret;
4c4b4cd2 10676
76a01679 10677 if (!ada_is_modular_type (type_arg))
323e0a4a 10678 error (_("'modulus must be applied to modular type"));
4c4b4cd2 10679
76a01679
JB
10680 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
10681 ada_modulus (type_arg));
4c4b4cd2
PH
10682 }
10683
10684
10685 case OP_ATR_POS:
10686 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10687 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10688 if (noside == EVAL_SKIP)
76a01679 10689 goto nosideret;
3cb382c9
UW
10690 type = builtin_type (exp->gdbarch)->builtin_int;
10691 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10692 return value_zero (type, not_lval);
14f9c5c9 10693 else
3cb382c9 10694 return value_pos_atr (type, arg1);
14f9c5c9 10695
4c4b4cd2
PH
10696 case OP_ATR_SIZE:
10697 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
10698 type = value_type (arg1);
10699
10700 /* If the argument is a reference, then dereference its type, since
10701 the user is really asking for the size of the actual object,
10702 not the size of the pointer. */
10703 if (TYPE_CODE (type) == TYPE_CODE_REF)
10704 type = TYPE_TARGET_TYPE (type);
10705
4c4b4cd2 10706 if (noside == EVAL_SKIP)
76a01679 10707 goto nosideret;
4c4b4cd2 10708 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 10709 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 10710 else
22601c15 10711 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 10712 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
10713
10714 case OP_ATR_VAL:
10715 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 10716 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 10717 type = exp->elts[pc + 2].type;
14f9c5c9 10718 if (noside == EVAL_SKIP)
76a01679 10719 goto nosideret;
4c4b4cd2 10720 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10721 return value_zero (type, not_lval);
4c4b4cd2 10722 else
76a01679 10723 return value_val_atr (type, arg1);
4c4b4cd2
PH
10724
10725 case BINOP_EXP:
10726 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10727 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10728 if (noside == EVAL_SKIP)
10729 goto nosideret;
10730 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10731 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 10732 else
f44316fa
UW
10733 {
10734 /* For integer exponentiation operations,
10735 only promote the first argument. */
10736 if (is_integral_type (value_type (arg2)))
10737 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10738 else
10739 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10740
10741 return value_binop (arg1, arg2, op);
10742 }
4c4b4cd2
PH
10743
10744 case UNOP_PLUS:
10745 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10746 if (noside == EVAL_SKIP)
10747 goto nosideret;
10748 else
10749 return arg1;
10750
10751 case UNOP_ABS:
10752 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10753 if (noside == EVAL_SKIP)
10754 goto nosideret;
f44316fa 10755 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 10756 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 10757 return value_neg (arg1);
14f9c5c9 10758 else
4c4b4cd2 10759 return arg1;
14f9c5c9
AS
10760
10761 case UNOP_IND:
5ec18f2b 10762 preeval_pos = *pos;
6b0d7253 10763 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10764 if (noside == EVAL_SKIP)
4c4b4cd2 10765 goto nosideret;
df407dfe 10766 type = ada_check_typedef (value_type (arg1));
14f9c5c9 10767 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
10768 {
10769 if (ada_is_array_descriptor_type (type))
10770 /* GDB allows dereferencing GNAT array descriptors. */
10771 {
10772 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 10773
4c4b4cd2 10774 if (arrType == NULL)
323e0a4a 10775 error (_("Attempt to dereference null array pointer."));
00a4c844 10776 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
10777 }
10778 else if (TYPE_CODE (type) == TYPE_CODE_PTR
10779 || TYPE_CODE (type) == TYPE_CODE_REF
10780 /* In C you can dereference an array to get the 1st elt. */
10781 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab 10782 {
5ec18f2b
JG
10783 /* As mentioned in the OP_VAR_VALUE case, tagged types can
10784 only be determined by inspecting the object's tag.
10785 This means that we need to evaluate completely the
10786 expression in order to get its type. */
10787
023db19c
JB
10788 if ((TYPE_CODE (type) == TYPE_CODE_REF
10789 || TYPE_CODE (type) == TYPE_CODE_PTR)
5ec18f2b
JG
10790 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
10791 {
10792 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
10793 EVAL_NORMAL);
10794 type = value_type (ada_value_ind (arg1));
10795 }
10796 else
10797 {
10798 type = to_static_fixed_type
10799 (ada_aligned_type
10800 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10801 }
10802 check_size (type);
714e53ab
PH
10803 return value_zero (type, lval_memory);
10804 }
4c4b4cd2 10805 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
10806 {
10807 /* GDB allows dereferencing an int. */
10808 if (expect_type == NULL)
10809 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10810 lval_memory);
10811 else
10812 {
10813 expect_type =
10814 to_static_fixed_type (ada_aligned_type (expect_type));
10815 return value_zero (expect_type, lval_memory);
10816 }
10817 }
4c4b4cd2 10818 else
323e0a4a 10819 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 10820 }
0963b4bd 10821 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 10822 type = ada_check_typedef (value_type (arg1));
d2e4a39e 10823
96967637
JB
10824 if (TYPE_CODE (type) == TYPE_CODE_INT)
10825 /* GDB allows dereferencing an int. If we were given
10826 the expect_type, then use that as the target type.
10827 Otherwise, assume that the target type is an int. */
10828 {
10829 if (expect_type != NULL)
10830 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10831 arg1));
10832 else
10833 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10834 (CORE_ADDR) value_as_address (arg1));
10835 }
6b0d7253 10836
4c4b4cd2
PH
10837 if (ada_is_array_descriptor_type (type))
10838 /* GDB allows dereferencing GNAT array descriptors. */
10839 return ada_coerce_to_simple_array (arg1);
14f9c5c9 10840 else
4c4b4cd2 10841 return ada_value_ind (arg1);
14f9c5c9
AS
10842
10843 case STRUCTOP_STRUCT:
10844 tem = longest_to_int (exp->elts[pc + 1].longconst);
10845 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
5ec18f2b 10846 preeval_pos = *pos;
14f9c5c9
AS
10847 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10848 if (noside == EVAL_SKIP)
4c4b4cd2 10849 goto nosideret;
14f9c5c9 10850 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10851 {
df407dfe 10852 struct type *type1 = value_type (arg1);
5b4ee69b 10853
76a01679
JB
10854 if (ada_is_tagged_type (type1, 1))
10855 {
10856 type = ada_lookup_struct_elt_type (type1,
10857 &exp->elts[pc + 2].string,
10858 1, 1, NULL);
5ec18f2b
JG
10859
10860 /* If the field is not found, check if it exists in the
10861 extension of this object's type. This means that we
10862 need to evaluate completely the expression. */
10863
76a01679 10864 if (type == NULL)
5ec18f2b
JG
10865 {
10866 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
10867 EVAL_NORMAL);
10868 arg1 = ada_value_struct_elt (arg1,
10869 &exp->elts[pc + 2].string,
10870 0);
10871 arg1 = unwrap_value (arg1);
10872 type = value_type (ada_to_fixed_value (arg1));
10873 }
76a01679
JB
10874 }
10875 else
10876 type =
10877 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
10878 0, NULL);
10879
10880 return value_zero (ada_aligned_type (type), lval_memory);
10881 }
14f9c5c9 10882 else
284614f0
JB
10883 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
10884 arg1 = unwrap_value (arg1);
10885 return ada_to_fixed_value (arg1);
10886
14f9c5c9 10887 case OP_TYPE:
4c4b4cd2
PH
10888 /* The value is not supposed to be used. This is here to make it
10889 easier to accommodate expressions that contain types. */
14f9c5c9
AS
10890 (*pos) += 2;
10891 if (noside == EVAL_SKIP)
4c4b4cd2 10892 goto nosideret;
14f9c5c9 10893 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 10894 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 10895 else
323e0a4a 10896 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
10897
10898 case OP_AGGREGATE:
10899 case OP_CHOICES:
10900 case OP_OTHERS:
10901 case OP_DISCRETE_RANGE:
10902 case OP_POSITIONAL:
10903 case OP_NAME:
10904 if (noside == EVAL_NORMAL)
10905 switch (op)
10906 {
10907 case OP_NAME:
10908 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 10909 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
10910 case OP_AGGREGATE:
10911 error (_("Aggregates only allowed on the right of an assignment"));
10912 default:
0963b4bd
MS
10913 internal_error (__FILE__, __LINE__,
10914 _("aggregate apparently mangled"));
52ce6436
PH
10915 }
10916
10917 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10918 *pos += oplen - 1;
10919 for (tem = 0; tem < nargs; tem += 1)
10920 ada_evaluate_subexp (NULL, exp, pos, noside);
10921 goto nosideret;
14f9c5c9
AS
10922 }
10923
10924nosideret:
22601c15 10925 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
14f9c5c9 10926}
14f9c5c9 10927\f
d2e4a39e 10928
4c4b4cd2 10929 /* Fixed point */
14f9c5c9
AS
10930
10931/* If TYPE encodes an Ada fixed-point type, return the suffix of the
10932 type name that encodes the 'small and 'delta information.
4c4b4cd2 10933 Otherwise, return NULL. */
14f9c5c9 10934
d2e4a39e 10935static const char *
ebf56fd3 10936fixed_type_info (struct type *type)
14f9c5c9 10937{
d2e4a39e 10938 const char *name = ada_type_name (type);
14f9c5c9
AS
10939 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
10940
d2e4a39e
AS
10941 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
10942 {
14f9c5c9 10943 const char *tail = strstr (name, "___XF_");
5b4ee69b 10944
14f9c5c9 10945 if (tail == NULL)
4c4b4cd2 10946 return NULL;
d2e4a39e 10947 else
4c4b4cd2 10948 return tail + 5;
14f9c5c9
AS
10949 }
10950 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
10951 return fixed_type_info (TYPE_TARGET_TYPE (type));
10952 else
10953 return NULL;
10954}
10955
4c4b4cd2 10956/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
10957
10958int
ebf56fd3 10959ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
10960{
10961 return fixed_type_info (type) != NULL;
10962}
10963
4c4b4cd2
PH
10964/* Return non-zero iff TYPE represents a System.Address type. */
10965
10966int
10967ada_is_system_address_type (struct type *type)
10968{
10969 return (TYPE_NAME (type)
10970 && strcmp (TYPE_NAME (type), "system__address") == 0);
10971}
10972
14f9c5c9
AS
10973/* Assuming that TYPE is the representation of an Ada fixed-point
10974 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 10975 delta cannot be determined. */
14f9c5c9
AS
10976
10977DOUBLEST
ebf56fd3 10978ada_delta (struct type *type)
14f9c5c9
AS
10979{
10980 const char *encoding = fixed_type_info (type);
facc390f 10981 DOUBLEST num, den;
14f9c5c9 10982
facc390f
JB
10983 /* Strictly speaking, num and den are encoded as integer. However,
10984 they may not fit into a long, and they will have to be converted
10985 to DOUBLEST anyway. So scan them as DOUBLEST. */
10986 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10987 &num, &den) < 2)
14f9c5c9 10988 return -1.0;
d2e4a39e 10989 else
facc390f 10990 return num / den;
14f9c5c9
AS
10991}
10992
10993/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 10994 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
10995
10996static DOUBLEST
ebf56fd3 10997scaling_factor (struct type *type)
14f9c5c9
AS
10998{
10999 const char *encoding = fixed_type_info (type);
facc390f 11000 DOUBLEST num0, den0, num1, den1;
14f9c5c9 11001 int n;
d2e4a39e 11002
facc390f
JB
11003 /* Strictly speaking, num's and den's are encoded as integer. However,
11004 they may not fit into a long, and they will have to be converted
11005 to DOUBLEST anyway. So scan them as DOUBLEST. */
11006 n = sscanf (encoding,
11007 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
11008 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
11009 &num0, &den0, &num1, &den1);
14f9c5c9
AS
11010
11011 if (n < 2)
11012 return 1.0;
11013 else if (n == 4)
facc390f 11014 return num1 / den1;
d2e4a39e 11015 else
facc390f 11016 return num0 / den0;
14f9c5c9
AS
11017}
11018
11019
11020/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 11021 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
11022
11023DOUBLEST
ebf56fd3 11024ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 11025{
d2e4a39e 11026 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
11027}
11028
4c4b4cd2
PH
11029/* The representation of a fixed-point value of type TYPE
11030 corresponding to the value X. */
14f9c5c9
AS
11031
11032LONGEST
ebf56fd3 11033ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
11034{
11035 return (LONGEST) (x / scaling_factor (type) + 0.5);
11036}
11037
14f9c5c9 11038\f
d2e4a39e 11039
4c4b4cd2 11040 /* Range types */
14f9c5c9
AS
11041
11042/* Scan STR beginning at position K for a discriminant name, and
11043 return the value of that discriminant field of DVAL in *PX. If
11044 PNEW_K is not null, put the position of the character beyond the
11045 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 11046 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
11047
11048static int
07d8f827 11049scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
76a01679 11050 int *pnew_k)
14f9c5c9
AS
11051{
11052 static char *bound_buffer = NULL;
11053 static size_t bound_buffer_len = 0;
11054 char *bound;
11055 char *pend;
d2e4a39e 11056 struct value *bound_val;
14f9c5c9
AS
11057
11058 if (dval == NULL || str == NULL || str[k] == '\0')
11059 return 0;
11060
d2e4a39e 11061 pend = strstr (str + k, "__");
14f9c5c9
AS
11062 if (pend == NULL)
11063 {
d2e4a39e 11064 bound = str + k;
14f9c5c9
AS
11065 k += strlen (bound);
11066 }
d2e4a39e 11067 else
14f9c5c9 11068 {
d2e4a39e 11069 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
14f9c5c9 11070 bound = bound_buffer;
d2e4a39e
AS
11071 strncpy (bound_buffer, str + k, pend - (str + k));
11072 bound[pend - (str + k)] = '\0';
11073 k = pend - str;
14f9c5c9 11074 }
d2e4a39e 11075
df407dfe 11076 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11077 if (bound_val == NULL)
11078 return 0;
11079
11080 *px = value_as_long (bound_val);
11081 if (pnew_k != NULL)
11082 *pnew_k = k;
11083 return 1;
11084}
11085
11086/* Value of variable named NAME in the current environment. If
11087 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11088 otherwise causes an error with message ERR_MSG. */
11089
d2e4a39e
AS
11090static struct value *
11091get_var_value (char *name, char *err_msg)
14f9c5c9 11092{
4c4b4cd2 11093 struct ada_symbol_info *syms;
14f9c5c9
AS
11094 int nsyms;
11095
4c4b4cd2 11096 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
4eeaa230 11097 &syms);
14f9c5c9
AS
11098
11099 if (nsyms != 1)
11100 {
11101 if (err_msg == NULL)
4c4b4cd2 11102 return 0;
14f9c5c9 11103 else
8a3fe4f8 11104 error (("%s"), err_msg);
14f9c5c9
AS
11105 }
11106
4c4b4cd2 11107 return value_of_variable (syms[0].sym, syms[0].block);
14f9c5c9 11108}
d2e4a39e 11109
14f9c5c9 11110/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
11111 no such variable found, returns 0, and sets *FLAG to 0. If
11112 successful, sets *FLAG to 1. */
11113
14f9c5c9 11114LONGEST
4c4b4cd2 11115get_int_var_value (char *name, int *flag)
14f9c5c9 11116{
4c4b4cd2 11117 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11118
14f9c5c9
AS
11119 if (var_val == 0)
11120 {
11121 if (flag != NULL)
4c4b4cd2 11122 *flag = 0;
14f9c5c9
AS
11123 return 0;
11124 }
11125 else
11126 {
11127 if (flag != NULL)
4c4b4cd2 11128 *flag = 1;
14f9c5c9
AS
11129 return value_as_long (var_val);
11130 }
11131}
d2e4a39e 11132
14f9c5c9
AS
11133
11134/* Return a range type whose base type is that of the range type named
11135 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11136 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11137 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11138 corresponding range type from debug information; fall back to using it
11139 if symbol lookup fails. If a new type must be created, allocate it
11140 like ORIG_TYPE was. The bounds information, in general, is encoded
11141 in NAME, the base type given in the named range type. */
14f9c5c9 11142
d2e4a39e 11143static struct type *
28c85d6c 11144to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11145{
0d5cff50 11146 const char *name;
14f9c5c9 11147 struct type *base_type;
d2e4a39e 11148 char *subtype_info;
14f9c5c9 11149
28c85d6c
JB
11150 gdb_assert (raw_type != NULL);
11151 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11152
1ce677a4 11153 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11154 base_type = TYPE_TARGET_TYPE (raw_type);
11155 else
11156 base_type = raw_type;
11157
28c85d6c 11158 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11159 subtype_info = strstr (name, "___XD");
11160 if (subtype_info == NULL)
690cc4eb 11161 {
43bbcdc2
PH
11162 LONGEST L = ada_discrete_type_low_bound (raw_type);
11163 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11164
690cc4eb
PH
11165 if (L < INT_MIN || U > INT_MAX)
11166 return raw_type;
11167 else
0c9c3474
SA
11168 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11169 L, U);
690cc4eb 11170 }
14f9c5c9
AS
11171 else
11172 {
11173 static char *name_buf = NULL;
11174 static size_t name_len = 0;
11175 int prefix_len = subtype_info - name;
11176 LONGEST L, U;
11177 struct type *type;
11178 char *bounds_str;
11179 int n;
11180
11181 GROW_VECT (name_buf, name_len, prefix_len + 5);
11182 strncpy (name_buf, name, prefix_len);
11183 name_buf[prefix_len] = '\0';
11184
11185 subtype_info += 5;
11186 bounds_str = strchr (subtype_info, '_');
11187 n = 1;
11188
d2e4a39e 11189 if (*subtype_info == 'L')
4c4b4cd2
PH
11190 {
11191 if (!ada_scan_number (bounds_str, n, &L, &n)
11192 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11193 return raw_type;
11194 if (bounds_str[n] == '_')
11195 n += 2;
0963b4bd 11196 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11197 n += 1;
11198 subtype_info += 1;
11199 }
d2e4a39e 11200 else
4c4b4cd2
PH
11201 {
11202 int ok;
5b4ee69b 11203
4c4b4cd2
PH
11204 strcpy (name_buf + prefix_len, "___L");
11205 L = get_int_var_value (name_buf, &ok);
11206 if (!ok)
11207 {
323e0a4a 11208 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11209 L = 1;
11210 }
11211 }
14f9c5c9 11212
d2e4a39e 11213 if (*subtype_info == 'U')
4c4b4cd2
PH
11214 {
11215 if (!ada_scan_number (bounds_str, n, &U, &n)
11216 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11217 return raw_type;
11218 }
d2e4a39e 11219 else
4c4b4cd2
PH
11220 {
11221 int ok;
5b4ee69b 11222
4c4b4cd2
PH
11223 strcpy (name_buf + prefix_len, "___U");
11224 U = get_int_var_value (name_buf, &ok);
11225 if (!ok)
11226 {
323e0a4a 11227 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11228 U = L;
11229 }
11230 }
14f9c5c9 11231
0c9c3474
SA
11232 type = create_static_range_type (alloc_type_copy (raw_type),
11233 base_type, L, U);
d2e4a39e 11234 TYPE_NAME (type) = name;
14f9c5c9
AS
11235 return type;
11236 }
11237}
11238
4c4b4cd2
PH
11239/* True iff NAME is the name of a range type. */
11240
14f9c5c9 11241int
d2e4a39e 11242ada_is_range_type_name (const char *name)
14f9c5c9
AS
11243{
11244 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11245}
14f9c5c9 11246\f
d2e4a39e 11247
4c4b4cd2
PH
11248 /* Modular types */
11249
11250/* True iff TYPE is an Ada modular type. */
14f9c5c9 11251
14f9c5c9 11252int
d2e4a39e 11253ada_is_modular_type (struct type *type)
14f9c5c9 11254{
18af8284 11255 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11256
11257 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11258 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11259 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11260}
11261
4c4b4cd2
PH
11262/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11263
61ee279c 11264ULONGEST
0056e4d5 11265ada_modulus (struct type *type)
14f9c5c9 11266{
43bbcdc2 11267 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11268}
d2e4a39e 11269\f
f7f9143b
JB
11270
11271/* Ada exception catchpoint support:
11272 ---------------------------------
11273
11274 We support 3 kinds of exception catchpoints:
11275 . catchpoints on Ada exceptions
11276 . catchpoints on unhandled Ada exceptions
11277 . catchpoints on failed assertions
11278
11279 Exceptions raised during failed assertions, or unhandled exceptions
11280 could perfectly be caught with the general catchpoint on Ada exceptions.
11281 However, we can easily differentiate these two special cases, and having
11282 the option to distinguish these two cases from the rest can be useful
11283 to zero-in on certain situations.
11284
11285 Exception catchpoints are a specialized form of breakpoint,
11286 since they rely on inserting breakpoints inside known routines
11287 of the GNAT runtime. The implementation therefore uses a standard
11288 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11289 of breakpoint_ops.
11290
0259addd
JB
11291 Support in the runtime for exception catchpoints have been changed
11292 a few times already, and these changes affect the implementation
11293 of these catchpoints. In order to be able to support several
11294 variants of the runtime, we use a sniffer that will determine
28010a5d 11295 the runtime variant used by the program being debugged. */
f7f9143b 11296
3d0b0fa3
JB
11297/* Ada's standard exceptions. */
11298
11299static char *standard_exc[] = {
11300 "constraint_error",
11301 "program_error",
11302 "storage_error",
11303 "tasking_error"
11304};
11305
0259addd
JB
11306typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11307
11308/* A structure that describes how to support exception catchpoints
11309 for a given executable. */
11310
11311struct exception_support_info
11312{
11313 /* The name of the symbol to break on in order to insert
11314 a catchpoint on exceptions. */
11315 const char *catch_exception_sym;
11316
11317 /* The name of the symbol to break on in order to insert
11318 a catchpoint on unhandled exceptions. */
11319 const char *catch_exception_unhandled_sym;
11320
11321 /* The name of the symbol to break on in order to insert
11322 a catchpoint on failed assertions. */
11323 const char *catch_assert_sym;
11324
11325 /* Assuming that the inferior just triggered an unhandled exception
11326 catchpoint, this function is responsible for returning the address
11327 in inferior memory where the name of that exception is stored.
11328 Return zero if the address could not be computed. */
11329 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11330};
11331
11332static CORE_ADDR ada_unhandled_exception_name_addr (void);
11333static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11334
11335/* The following exception support info structure describes how to
11336 implement exception catchpoints with the latest version of the
11337 Ada runtime (as of 2007-03-06). */
11338
11339static const struct exception_support_info default_exception_support_info =
11340{
11341 "__gnat_debug_raise_exception", /* catch_exception_sym */
11342 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11343 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11344 ada_unhandled_exception_name_addr
11345};
11346
11347/* The following exception support info structure describes how to
11348 implement exception catchpoints with a slightly older version
11349 of the Ada runtime. */
11350
11351static const struct exception_support_info exception_support_info_fallback =
11352{
11353 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11354 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11355 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11356 ada_unhandled_exception_name_addr_from_raise
11357};
11358
f17011e0
JB
11359/* Return nonzero if we can detect the exception support routines
11360 described in EINFO.
11361
11362 This function errors out if an abnormal situation is detected
11363 (for instance, if we find the exception support routines, but
11364 that support is found to be incomplete). */
11365
11366static int
11367ada_has_this_exception_support (const struct exception_support_info *einfo)
11368{
11369 struct symbol *sym;
11370
11371 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11372 that should be compiled with debugging information. As a result, we
11373 expect to find that symbol in the symtabs. */
11374
11375 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11376 if (sym == NULL)
a6af7abe
JB
11377 {
11378 /* Perhaps we did not find our symbol because the Ada runtime was
11379 compiled without debugging info, or simply stripped of it.
11380 It happens on some GNU/Linux distributions for instance, where
11381 users have to install a separate debug package in order to get
11382 the runtime's debugging info. In that situation, let the user
11383 know why we cannot insert an Ada exception catchpoint.
11384
11385 Note: Just for the purpose of inserting our Ada exception
11386 catchpoint, we could rely purely on the associated minimal symbol.
11387 But we would be operating in degraded mode anyway, since we are
11388 still lacking the debugging info needed later on to extract
11389 the name of the exception being raised (this name is printed in
11390 the catchpoint message, and is also used when trying to catch
11391 a specific exception). We do not handle this case for now. */
3b7344d5 11392 struct bound_minimal_symbol msym
1c8e84b0
JB
11393 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11394
3b7344d5 11395 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
11396 error (_("Your Ada runtime appears to be missing some debugging "
11397 "information.\nCannot insert Ada exception catchpoint "
11398 "in this configuration."));
11399
11400 return 0;
11401 }
f17011e0
JB
11402
11403 /* Make sure that the symbol we found corresponds to a function. */
11404
11405 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11406 error (_("Symbol \"%s\" is not a function (class = %d)"),
11407 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11408
11409 return 1;
11410}
11411
0259addd
JB
11412/* Inspect the Ada runtime and determine which exception info structure
11413 should be used to provide support for exception catchpoints.
11414
3eecfa55
JB
11415 This function will always set the per-inferior exception_info,
11416 or raise an error. */
0259addd
JB
11417
11418static void
11419ada_exception_support_info_sniffer (void)
11420{
3eecfa55 11421 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
11422
11423 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 11424 if (data->exception_info != NULL)
0259addd
JB
11425 return;
11426
11427 /* Check the latest (default) exception support info. */
f17011e0 11428 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 11429 {
3eecfa55 11430 data->exception_info = &default_exception_support_info;
0259addd
JB
11431 return;
11432 }
11433
11434 /* Try our fallback exception suport info. */
f17011e0 11435 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 11436 {
3eecfa55 11437 data->exception_info = &exception_support_info_fallback;
0259addd
JB
11438 return;
11439 }
11440
11441 /* Sometimes, it is normal for us to not be able to find the routine
11442 we are looking for. This happens when the program is linked with
11443 the shared version of the GNAT runtime, and the program has not been
11444 started yet. Inform the user of these two possible causes if
11445 applicable. */
11446
ccefe4c4 11447 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
11448 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11449
11450 /* If the symbol does not exist, then check that the program is
11451 already started, to make sure that shared libraries have been
11452 loaded. If it is not started, this may mean that the symbol is
11453 in a shared library. */
11454
11455 if (ptid_get_pid (inferior_ptid) == 0)
11456 error (_("Unable to insert catchpoint. Try to start the program first."));
11457
11458 /* At this point, we know that we are debugging an Ada program and
11459 that the inferior has been started, but we still are not able to
0963b4bd 11460 find the run-time symbols. That can mean that we are in
0259addd
JB
11461 configurable run time mode, or that a-except as been optimized
11462 out by the linker... In any case, at this point it is not worth
11463 supporting this feature. */
11464
7dda8cff 11465 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
11466}
11467
f7f9143b
JB
11468/* True iff FRAME is very likely to be that of a function that is
11469 part of the runtime system. This is all very heuristic, but is
11470 intended to be used as advice as to what frames are uninteresting
11471 to most users. */
11472
11473static int
11474is_known_support_routine (struct frame_info *frame)
11475{
4ed6b5be 11476 struct symtab_and_line sal;
55b87a52 11477 char *func_name;
692465f1 11478 enum language func_lang;
f7f9143b 11479 int i;
f35a17b5 11480 const char *fullname;
f7f9143b 11481
4ed6b5be
JB
11482 /* If this code does not have any debugging information (no symtab),
11483 This cannot be any user code. */
f7f9143b 11484
4ed6b5be 11485 find_frame_sal (frame, &sal);
f7f9143b
JB
11486 if (sal.symtab == NULL)
11487 return 1;
11488
4ed6b5be
JB
11489 /* If there is a symtab, but the associated source file cannot be
11490 located, then assume this is not user code: Selecting a frame
11491 for which we cannot display the code would not be very helpful
11492 for the user. This should also take care of case such as VxWorks
11493 where the kernel has some debugging info provided for a few units. */
f7f9143b 11494
f35a17b5
JK
11495 fullname = symtab_to_fullname (sal.symtab);
11496 if (access (fullname, R_OK) != 0)
f7f9143b
JB
11497 return 1;
11498
4ed6b5be
JB
11499 /* Check the unit filename againt the Ada runtime file naming.
11500 We also check the name of the objfile against the name of some
11501 known system libraries that sometimes come with debugging info
11502 too. */
11503
f7f9143b
JB
11504 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11505 {
11506 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 11507 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 11508 return 1;
4ed6b5be 11509 if (sal.symtab->objfile != NULL
4262abfb 11510 && re_exec (objfile_name (sal.symtab->objfile)))
4ed6b5be 11511 return 1;
f7f9143b
JB
11512 }
11513
4ed6b5be 11514 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 11515
e9e07ba6 11516 find_frame_funname (frame, &func_name, &func_lang, NULL);
f7f9143b
JB
11517 if (func_name == NULL)
11518 return 1;
11519
11520 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11521 {
11522 re_comp (known_auxiliary_function_name_patterns[i]);
11523 if (re_exec (func_name))
55b87a52
KS
11524 {
11525 xfree (func_name);
11526 return 1;
11527 }
f7f9143b
JB
11528 }
11529
55b87a52 11530 xfree (func_name);
f7f9143b
JB
11531 return 0;
11532}
11533
11534/* Find the first frame that contains debugging information and that is not
11535 part of the Ada run-time, starting from FI and moving upward. */
11536
0ef643c8 11537void
f7f9143b
JB
11538ada_find_printable_frame (struct frame_info *fi)
11539{
11540 for (; fi != NULL; fi = get_prev_frame (fi))
11541 {
11542 if (!is_known_support_routine (fi))
11543 {
11544 select_frame (fi);
11545 break;
11546 }
11547 }
11548
11549}
11550
11551/* Assuming that the inferior just triggered an unhandled exception
11552 catchpoint, return the address in inferior memory where the name
11553 of the exception is stored.
11554
11555 Return zero if the address could not be computed. */
11556
11557static CORE_ADDR
11558ada_unhandled_exception_name_addr (void)
0259addd
JB
11559{
11560 return parse_and_eval_address ("e.full_name");
11561}
11562
11563/* Same as ada_unhandled_exception_name_addr, except that this function
11564 should be used when the inferior uses an older version of the runtime,
11565 where the exception name needs to be extracted from a specific frame
11566 several frames up in the callstack. */
11567
11568static CORE_ADDR
11569ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
11570{
11571 int frame_level;
11572 struct frame_info *fi;
3eecfa55 11573 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
55b87a52 11574 struct cleanup *old_chain;
f7f9143b
JB
11575
11576 /* To determine the name of this exception, we need to select
11577 the frame corresponding to RAISE_SYM_NAME. This frame is
11578 at least 3 levels up, so we simply skip the first 3 frames
11579 without checking the name of their associated function. */
11580 fi = get_current_frame ();
11581 for (frame_level = 0; frame_level < 3; frame_level += 1)
11582 if (fi != NULL)
11583 fi = get_prev_frame (fi);
11584
55b87a52 11585 old_chain = make_cleanup (null_cleanup, NULL);
f7f9143b
JB
11586 while (fi != NULL)
11587 {
55b87a52 11588 char *func_name;
692465f1
JB
11589 enum language func_lang;
11590
e9e07ba6 11591 find_frame_funname (fi, &func_name, &func_lang, NULL);
55b87a52
KS
11592 if (func_name != NULL)
11593 {
11594 make_cleanup (xfree, func_name);
11595
11596 if (strcmp (func_name,
11597 data->exception_info->catch_exception_sym) == 0)
11598 break; /* We found the frame we were looking for... */
11599 fi = get_prev_frame (fi);
11600 }
f7f9143b 11601 }
55b87a52 11602 do_cleanups (old_chain);
f7f9143b
JB
11603
11604 if (fi == NULL)
11605 return 0;
11606
11607 select_frame (fi);
11608 return parse_and_eval_address ("id.full_name");
11609}
11610
11611/* Assuming the inferior just triggered an Ada exception catchpoint
11612 (of any type), return the address in inferior memory where the name
11613 of the exception is stored, if applicable.
11614
11615 Return zero if the address could not be computed, or if not relevant. */
11616
11617static CORE_ADDR
761269c8 11618ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11619 struct breakpoint *b)
11620{
3eecfa55
JB
11621 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11622
f7f9143b
JB
11623 switch (ex)
11624 {
761269c8 11625 case ada_catch_exception:
f7f9143b
JB
11626 return (parse_and_eval_address ("e.full_name"));
11627 break;
11628
761269c8 11629 case ada_catch_exception_unhandled:
3eecfa55 11630 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
11631 break;
11632
761269c8 11633 case ada_catch_assert:
f7f9143b
JB
11634 return 0; /* Exception name is not relevant in this case. */
11635 break;
11636
11637 default:
11638 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11639 break;
11640 }
11641
11642 return 0; /* Should never be reached. */
11643}
11644
11645/* Same as ada_exception_name_addr_1, except that it intercepts and contains
11646 any error that ada_exception_name_addr_1 might cause to be thrown.
11647 When an error is intercepted, a warning with the error message is printed,
11648 and zero is returned. */
11649
11650static CORE_ADDR
761269c8 11651ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11652 struct breakpoint *b)
11653{
bfd189b1 11654 volatile struct gdb_exception e;
f7f9143b
JB
11655 CORE_ADDR result = 0;
11656
11657 TRY_CATCH (e, RETURN_MASK_ERROR)
11658 {
11659 result = ada_exception_name_addr_1 (ex, b);
11660 }
11661
11662 if (e.reason < 0)
11663 {
11664 warning (_("failed to get exception name: %s"), e.message);
11665 return 0;
11666 }
11667
11668 return result;
11669}
11670
28010a5d
PA
11671static char *ada_exception_catchpoint_cond_string (const char *excep_string);
11672
11673/* Ada catchpoints.
11674
11675 In the case of catchpoints on Ada exceptions, the catchpoint will
11676 stop the target on every exception the program throws. When a user
11677 specifies the name of a specific exception, we translate this
11678 request into a condition expression (in text form), and then parse
11679 it into an expression stored in each of the catchpoint's locations.
11680 We then use this condition to check whether the exception that was
11681 raised is the one the user is interested in. If not, then the
11682 target is resumed again. We store the name of the requested
11683 exception, in order to be able to re-set the condition expression
11684 when symbols change. */
11685
11686/* An instance of this type is used to represent an Ada catchpoint
11687 breakpoint location. It includes a "struct bp_location" as a kind
11688 of base class; users downcast to "struct bp_location *" when
11689 needed. */
11690
11691struct ada_catchpoint_location
11692{
11693 /* The base class. */
11694 struct bp_location base;
11695
11696 /* The condition that checks whether the exception that was raised
11697 is the specific exception the user specified on catchpoint
11698 creation. */
11699 struct expression *excep_cond_expr;
11700};
11701
11702/* Implement the DTOR method in the bp_location_ops structure for all
11703 Ada exception catchpoint kinds. */
11704
11705static void
11706ada_catchpoint_location_dtor (struct bp_location *bl)
11707{
11708 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
11709
11710 xfree (al->excep_cond_expr);
11711}
11712
11713/* The vtable to be used in Ada catchpoint locations. */
11714
11715static const struct bp_location_ops ada_catchpoint_location_ops =
11716{
11717 ada_catchpoint_location_dtor
11718};
11719
11720/* An instance of this type is used to represent an Ada catchpoint.
11721 It includes a "struct breakpoint" as a kind of base class; users
11722 downcast to "struct breakpoint *" when needed. */
11723
11724struct ada_catchpoint
11725{
11726 /* The base class. */
11727 struct breakpoint base;
11728
11729 /* The name of the specific exception the user specified. */
11730 char *excep_string;
11731};
11732
11733/* Parse the exception condition string in the context of each of the
11734 catchpoint's locations, and store them for later evaluation. */
11735
11736static void
11737create_excep_cond_exprs (struct ada_catchpoint *c)
11738{
11739 struct cleanup *old_chain;
11740 struct bp_location *bl;
11741 char *cond_string;
11742
11743 /* Nothing to do if there's no specific exception to catch. */
11744 if (c->excep_string == NULL)
11745 return;
11746
11747 /* Same if there are no locations... */
11748 if (c->base.loc == NULL)
11749 return;
11750
11751 /* Compute the condition expression in text form, from the specific
11752 expection we want to catch. */
11753 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
11754 old_chain = make_cleanup (xfree, cond_string);
11755
11756 /* Iterate over all the catchpoint's locations, and parse an
11757 expression for each. */
11758 for (bl = c->base.loc; bl != NULL; bl = bl->next)
11759 {
11760 struct ada_catchpoint_location *ada_loc
11761 = (struct ada_catchpoint_location *) bl;
11762 struct expression *exp = NULL;
11763
11764 if (!bl->shlib_disabled)
11765 {
11766 volatile struct gdb_exception e;
bbc13ae3 11767 const char *s;
28010a5d
PA
11768
11769 s = cond_string;
11770 TRY_CATCH (e, RETURN_MASK_ERROR)
11771 {
1bb9788d
TT
11772 exp = parse_exp_1 (&s, bl->address,
11773 block_for_pc (bl->address), 0);
28010a5d
PA
11774 }
11775 if (e.reason < 0)
849f2b52
JB
11776 {
11777 warning (_("failed to reevaluate internal exception condition "
11778 "for catchpoint %d: %s"),
11779 c->base.number, e.message);
11780 /* There is a bug in GCC on sparc-solaris when building with
11781 optimization which causes EXP to change unexpectedly
11782 (http://gcc.gnu.org/bugzilla/show_bug.cgi?id=56982).
11783 The problem should be fixed starting with GCC 4.9.
11784 In the meantime, work around it by forcing EXP back
11785 to NULL. */
11786 exp = NULL;
11787 }
28010a5d
PA
11788 }
11789
11790 ada_loc->excep_cond_expr = exp;
11791 }
11792
11793 do_cleanups (old_chain);
11794}
11795
11796/* Implement the DTOR method in the breakpoint_ops structure for all
11797 exception catchpoint kinds. */
11798
11799static void
761269c8 11800dtor_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
11801{
11802 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11803
11804 xfree (c->excep_string);
348d480f 11805
2060206e 11806 bkpt_breakpoint_ops.dtor (b);
28010a5d
PA
11807}
11808
11809/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11810 structure for all exception catchpoint kinds. */
11811
11812static struct bp_location *
761269c8 11813allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
11814 struct breakpoint *self)
11815{
11816 struct ada_catchpoint_location *loc;
11817
11818 loc = XNEW (struct ada_catchpoint_location);
11819 init_bp_location (&loc->base, &ada_catchpoint_location_ops, self);
11820 loc->excep_cond_expr = NULL;
11821 return &loc->base;
11822}
11823
11824/* Implement the RE_SET method in the breakpoint_ops structure for all
11825 exception catchpoint kinds. */
11826
11827static void
761269c8 11828re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
11829{
11830 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11831
11832 /* Call the base class's method. This updates the catchpoint's
11833 locations. */
2060206e 11834 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
11835
11836 /* Reparse the exception conditional expressions. One for each
11837 location. */
11838 create_excep_cond_exprs (c);
11839}
11840
11841/* Returns true if we should stop for this breakpoint hit. If the
11842 user specified a specific exception, we only want to cause a stop
11843 if the program thrown that exception. */
11844
11845static int
11846should_stop_exception (const struct bp_location *bl)
11847{
11848 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11849 const struct ada_catchpoint_location *ada_loc
11850 = (const struct ada_catchpoint_location *) bl;
11851 volatile struct gdb_exception ex;
11852 int stop;
11853
11854 /* With no specific exception, should always stop. */
11855 if (c->excep_string == NULL)
11856 return 1;
11857
11858 if (ada_loc->excep_cond_expr == NULL)
11859 {
11860 /* We will have a NULL expression if back when we were creating
11861 the expressions, this location's had failed to parse. */
11862 return 1;
11863 }
11864
11865 stop = 1;
11866 TRY_CATCH (ex, RETURN_MASK_ALL)
11867 {
11868 struct value *mark;
11869
11870 mark = value_mark ();
11871 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr));
11872 value_free_to_mark (mark);
11873 }
11874 if (ex.reason < 0)
11875 exception_fprintf (gdb_stderr, ex,
11876 _("Error in testing exception condition:\n"));
11877 return stop;
11878}
11879
11880/* Implement the CHECK_STATUS method in the breakpoint_ops structure
11881 for all exception catchpoint kinds. */
11882
11883static void
761269c8 11884check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
11885{
11886 bs->stop = should_stop_exception (bs->bp_location_at);
11887}
11888
f7f9143b
JB
11889/* Implement the PRINT_IT method in the breakpoint_ops structure
11890 for all exception catchpoint kinds. */
11891
11892static enum print_stop_action
761269c8 11893print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 11894{
79a45e25 11895 struct ui_out *uiout = current_uiout;
348d480f
PA
11896 struct breakpoint *b = bs->breakpoint_at;
11897
956a9fb9 11898 annotate_catchpoint (b->number);
f7f9143b 11899
956a9fb9 11900 if (ui_out_is_mi_like_p (uiout))
f7f9143b 11901 {
956a9fb9
JB
11902 ui_out_field_string (uiout, "reason",
11903 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11904 ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition));
f7f9143b
JB
11905 }
11906
00eb2c4a
JB
11907 ui_out_text (uiout,
11908 b->disposition == disp_del ? "\nTemporary catchpoint "
11909 : "\nCatchpoint ");
956a9fb9
JB
11910 ui_out_field_int (uiout, "bkptno", b->number);
11911 ui_out_text (uiout, ", ");
f7f9143b 11912
f7f9143b
JB
11913 switch (ex)
11914 {
761269c8
JB
11915 case ada_catch_exception:
11916 case ada_catch_exception_unhandled:
956a9fb9
JB
11917 {
11918 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
11919 char exception_name[256];
11920
11921 if (addr != 0)
11922 {
c714b426
PA
11923 read_memory (addr, (gdb_byte *) exception_name,
11924 sizeof (exception_name) - 1);
956a9fb9
JB
11925 exception_name [sizeof (exception_name) - 1] = '\0';
11926 }
11927 else
11928 {
11929 /* For some reason, we were unable to read the exception
11930 name. This could happen if the Runtime was compiled
11931 without debugging info, for instance. In that case,
11932 just replace the exception name by the generic string
11933 "exception" - it will read as "an exception" in the
11934 notification we are about to print. */
967cff16 11935 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
11936 }
11937 /* In the case of unhandled exception breakpoints, we print
11938 the exception name as "unhandled EXCEPTION_NAME", to make
11939 it clearer to the user which kind of catchpoint just got
11940 hit. We used ui_out_text to make sure that this extra
11941 info does not pollute the exception name in the MI case. */
761269c8 11942 if (ex == ada_catch_exception_unhandled)
956a9fb9
JB
11943 ui_out_text (uiout, "unhandled ");
11944 ui_out_field_string (uiout, "exception-name", exception_name);
11945 }
11946 break;
761269c8 11947 case ada_catch_assert:
956a9fb9
JB
11948 /* In this case, the name of the exception is not really
11949 important. Just print "failed assertion" to make it clearer
11950 that his program just hit an assertion-failure catchpoint.
11951 We used ui_out_text because this info does not belong in
11952 the MI output. */
11953 ui_out_text (uiout, "failed assertion");
11954 break;
f7f9143b 11955 }
956a9fb9
JB
11956 ui_out_text (uiout, " at ");
11957 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
11958
11959 return PRINT_SRC_AND_LOC;
11960}
11961
11962/* Implement the PRINT_ONE method in the breakpoint_ops structure
11963 for all exception catchpoint kinds. */
11964
11965static void
761269c8 11966print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 11967 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 11968{
79a45e25 11969 struct ui_out *uiout = current_uiout;
28010a5d 11970 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
11971 struct value_print_options opts;
11972
11973 get_user_print_options (&opts);
11974 if (opts.addressprint)
f7f9143b
JB
11975 {
11976 annotate_field (4);
5af949e3 11977 ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
11978 }
11979
11980 annotate_field (5);
a6d9a66e 11981 *last_loc = b->loc;
f7f9143b
JB
11982 switch (ex)
11983 {
761269c8 11984 case ada_catch_exception:
28010a5d 11985 if (c->excep_string != NULL)
f7f9143b 11986 {
28010a5d
PA
11987 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11988
f7f9143b
JB
11989 ui_out_field_string (uiout, "what", msg);
11990 xfree (msg);
11991 }
11992 else
11993 ui_out_field_string (uiout, "what", "all Ada exceptions");
11994
11995 break;
11996
761269c8 11997 case ada_catch_exception_unhandled:
f7f9143b
JB
11998 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
11999 break;
12000
761269c8 12001 case ada_catch_assert:
f7f9143b
JB
12002 ui_out_field_string (uiout, "what", "failed Ada assertions");
12003 break;
12004
12005 default:
12006 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12007 break;
12008 }
12009}
12010
12011/* Implement the PRINT_MENTION method in the breakpoint_ops structure
12012 for all exception catchpoint kinds. */
12013
12014static void
761269c8 12015print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12016 struct breakpoint *b)
12017{
28010a5d 12018 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 12019 struct ui_out *uiout = current_uiout;
28010a5d 12020
00eb2c4a
JB
12021 ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ")
12022 : _("Catchpoint "));
12023 ui_out_field_int (uiout, "bkptno", b->number);
12024 ui_out_text (uiout, ": ");
12025
f7f9143b
JB
12026 switch (ex)
12027 {
761269c8 12028 case ada_catch_exception:
28010a5d 12029 if (c->excep_string != NULL)
00eb2c4a
JB
12030 {
12031 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12032 struct cleanup *old_chain = make_cleanup (xfree, info);
12033
12034 ui_out_text (uiout, info);
12035 do_cleanups (old_chain);
12036 }
f7f9143b 12037 else
00eb2c4a 12038 ui_out_text (uiout, _("all Ada exceptions"));
f7f9143b
JB
12039 break;
12040
761269c8 12041 case ada_catch_exception_unhandled:
00eb2c4a 12042 ui_out_text (uiout, _("unhandled Ada exceptions"));
f7f9143b
JB
12043 break;
12044
761269c8 12045 case ada_catch_assert:
00eb2c4a 12046 ui_out_text (uiout, _("failed Ada assertions"));
f7f9143b
JB
12047 break;
12048
12049 default:
12050 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12051 break;
12052 }
12053}
12054
6149aea9
PA
12055/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12056 for all exception catchpoint kinds. */
12057
12058static void
761269c8 12059print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
12060 struct breakpoint *b, struct ui_file *fp)
12061{
28010a5d
PA
12062 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12063
6149aea9
PA
12064 switch (ex)
12065 {
761269c8 12066 case ada_catch_exception:
6149aea9 12067 fprintf_filtered (fp, "catch exception");
28010a5d
PA
12068 if (c->excep_string != NULL)
12069 fprintf_filtered (fp, " %s", c->excep_string);
6149aea9
PA
12070 break;
12071
761269c8 12072 case ada_catch_exception_unhandled:
78076abc 12073 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12074 break;
12075
761269c8 12076 case ada_catch_assert:
6149aea9
PA
12077 fprintf_filtered (fp, "catch assert");
12078 break;
12079
12080 default:
12081 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12082 }
d9b3f62e 12083 print_recreate_thread (b, fp);
6149aea9
PA
12084}
12085
f7f9143b
JB
12086/* Virtual table for "catch exception" breakpoints. */
12087
28010a5d
PA
12088static void
12089dtor_catch_exception (struct breakpoint *b)
12090{
761269c8 12091 dtor_exception (ada_catch_exception, b);
28010a5d
PA
12092}
12093
12094static struct bp_location *
12095allocate_location_catch_exception (struct breakpoint *self)
12096{
761269c8 12097 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12098}
12099
12100static void
12101re_set_catch_exception (struct breakpoint *b)
12102{
761269c8 12103 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12104}
12105
12106static void
12107check_status_catch_exception (bpstat bs)
12108{
761269c8 12109 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12110}
12111
f7f9143b 12112static enum print_stop_action
348d480f 12113print_it_catch_exception (bpstat bs)
f7f9143b 12114{
761269c8 12115 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12116}
12117
12118static void
a6d9a66e 12119print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12120{
761269c8 12121 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12122}
12123
12124static void
12125print_mention_catch_exception (struct breakpoint *b)
12126{
761269c8 12127 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12128}
12129
6149aea9
PA
12130static void
12131print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12132{
761269c8 12133 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12134}
12135
2060206e 12136static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12137
12138/* Virtual table for "catch exception unhandled" breakpoints. */
12139
28010a5d
PA
12140static void
12141dtor_catch_exception_unhandled (struct breakpoint *b)
12142{
761269c8 12143 dtor_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12144}
12145
12146static struct bp_location *
12147allocate_location_catch_exception_unhandled (struct breakpoint *self)
12148{
761269c8 12149 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12150}
12151
12152static void
12153re_set_catch_exception_unhandled (struct breakpoint *b)
12154{
761269c8 12155 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12156}
12157
12158static void
12159check_status_catch_exception_unhandled (bpstat bs)
12160{
761269c8 12161 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12162}
12163
f7f9143b 12164static enum print_stop_action
348d480f 12165print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12166{
761269c8 12167 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12168}
12169
12170static void
a6d9a66e
UW
12171print_one_catch_exception_unhandled (struct breakpoint *b,
12172 struct bp_location **last_loc)
f7f9143b 12173{
761269c8 12174 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12175}
12176
12177static void
12178print_mention_catch_exception_unhandled (struct breakpoint *b)
12179{
761269c8 12180 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12181}
12182
6149aea9
PA
12183static void
12184print_recreate_catch_exception_unhandled (struct breakpoint *b,
12185 struct ui_file *fp)
12186{
761269c8 12187 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12188}
12189
2060206e 12190static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12191
12192/* Virtual table for "catch assert" breakpoints. */
12193
28010a5d
PA
12194static void
12195dtor_catch_assert (struct breakpoint *b)
12196{
761269c8 12197 dtor_exception (ada_catch_assert, b);
28010a5d
PA
12198}
12199
12200static struct bp_location *
12201allocate_location_catch_assert (struct breakpoint *self)
12202{
761269c8 12203 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12204}
12205
12206static void
12207re_set_catch_assert (struct breakpoint *b)
12208{
761269c8 12209 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12210}
12211
12212static void
12213check_status_catch_assert (bpstat bs)
12214{
761269c8 12215 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12216}
12217
f7f9143b 12218static enum print_stop_action
348d480f 12219print_it_catch_assert (bpstat bs)
f7f9143b 12220{
761269c8 12221 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12222}
12223
12224static void
a6d9a66e 12225print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12226{
761269c8 12227 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
12228}
12229
12230static void
12231print_mention_catch_assert (struct breakpoint *b)
12232{
761269c8 12233 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
12234}
12235
6149aea9
PA
12236static void
12237print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12238{
761269c8 12239 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
12240}
12241
2060206e 12242static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 12243
f7f9143b
JB
12244/* Return a newly allocated copy of the first space-separated token
12245 in ARGSP, and then adjust ARGSP to point immediately after that
12246 token.
12247
12248 Return NULL if ARGPS does not contain any more tokens. */
12249
12250static char *
12251ada_get_next_arg (char **argsp)
12252{
12253 char *args = *argsp;
12254 char *end;
12255 char *result;
12256
0fcd72ba 12257 args = skip_spaces (args);
f7f9143b
JB
12258 if (args[0] == '\0')
12259 return NULL; /* No more arguments. */
12260
12261 /* Find the end of the current argument. */
12262
0fcd72ba 12263 end = skip_to_space (args);
f7f9143b
JB
12264
12265 /* Adjust ARGSP to point to the start of the next argument. */
12266
12267 *argsp = end;
12268
12269 /* Make a copy of the current argument and return it. */
12270
12271 result = xmalloc (end - args + 1);
12272 strncpy (result, args, end - args);
12273 result[end - args] = '\0';
12274
12275 return result;
12276}
12277
12278/* Split the arguments specified in a "catch exception" command.
12279 Set EX to the appropriate catchpoint type.
28010a5d 12280 Set EXCEP_STRING to the name of the specific exception if
5845583d
JB
12281 specified by the user.
12282 If a condition is found at the end of the arguments, the condition
12283 expression is stored in COND_STRING (memory must be deallocated
12284 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
12285
12286static void
12287catch_ada_exception_command_split (char *args,
761269c8 12288 enum ada_exception_catchpoint_kind *ex,
5845583d
JB
12289 char **excep_string,
12290 char **cond_string)
f7f9143b
JB
12291{
12292 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
12293 char *exception_name;
5845583d 12294 char *cond = NULL;
f7f9143b
JB
12295
12296 exception_name = ada_get_next_arg (&args);
5845583d
JB
12297 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
12298 {
12299 /* This is not an exception name; this is the start of a condition
12300 expression for a catchpoint on all exceptions. So, "un-get"
12301 this token, and set exception_name to NULL. */
12302 xfree (exception_name);
12303 exception_name = NULL;
12304 args -= 2;
12305 }
f7f9143b
JB
12306 make_cleanup (xfree, exception_name);
12307
5845583d 12308 /* Check to see if we have a condition. */
f7f9143b 12309
0fcd72ba 12310 args = skip_spaces (args);
5845583d
JB
12311 if (strncmp (args, "if", 2) == 0
12312 && (isspace (args[2]) || args[2] == '\0'))
12313 {
12314 args += 2;
12315 args = skip_spaces (args);
12316
12317 if (args[0] == '\0')
12318 error (_("Condition missing after `if' keyword"));
12319 cond = xstrdup (args);
12320 make_cleanup (xfree, cond);
12321
12322 args += strlen (args);
12323 }
12324
12325 /* Check that we do not have any more arguments. Anything else
12326 is unexpected. */
f7f9143b
JB
12327
12328 if (args[0] != '\0')
12329 error (_("Junk at end of expression"));
12330
12331 discard_cleanups (old_chain);
12332
12333 if (exception_name == NULL)
12334 {
12335 /* Catch all exceptions. */
761269c8 12336 *ex = ada_catch_exception;
28010a5d 12337 *excep_string = NULL;
f7f9143b
JB
12338 }
12339 else if (strcmp (exception_name, "unhandled") == 0)
12340 {
12341 /* Catch unhandled exceptions. */
761269c8 12342 *ex = ada_catch_exception_unhandled;
28010a5d 12343 *excep_string = NULL;
f7f9143b
JB
12344 }
12345 else
12346 {
12347 /* Catch a specific exception. */
761269c8 12348 *ex = ada_catch_exception;
28010a5d 12349 *excep_string = exception_name;
f7f9143b 12350 }
5845583d 12351 *cond_string = cond;
f7f9143b
JB
12352}
12353
12354/* Return the name of the symbol on which we should break in order to
12355 implement a catchpoint of the EX kind. */
12356
12357static const char *
761269c8 12358ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 12359{
3eecfa55
JB
12360 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12361
12362 gdb_assert (data->exception_info != NULL);
0259addd 12363
f7f9143b
JB
12364 switch (ex)
12365 {
761269c8 12366 case ada_catch_exception:
3eecfa55 12367 return (data->exception_info->catch_exception_sym);
f7f9143b 12368 break;
761269c8 12369 case ada_catch_exception_unhandled:
3eecfa55 12370 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 12371 break;
761269c8 12372 case ada_catch_assert:
3eecfa55 12373 return (data->exception_info->catch_assert_sym);
f7f9143b
JB
12374 break;
12375 default:
12376 internal_error (__FILE__, __LINE__,
12377 _("unexpected catchpoint kind (%d)"), ex);
12378 }
12379}
12380
12381/* Return the breakpoint ops "virtual table" used for catchpoints
12382 of the EX kind. */
12383
c0a91b2b 12384static const struct breakpoint_ops *
761269c8 12385ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
12386{
12387 switch (ex)
12388 {
761269c8 12389 case ada_catch_exception:
f7f9143b
JB
12390 return (&catch_exception_breakpoint_ops);
12391 break;
761269c8 12392 case ada_catch_exception_unhandled:
f7f9143b
JB
12393 return (&catch_exception_unhandled_breakpoint_ops);
12394 break;
761269c8 12395 case ada_catch_assert:
f7f9143b
JB
12396 return (&catch_assert_breakpoint_ops);
12397 break;
12398 default:
12399 internal_error (__FILE__, __LINE__,
12400 _("unexpected catchpoint kind (%d)"), ex);
12401 }
12402}
12403
12404/* Return the condition that will be used to match the current exception
12405 being raised with the exception that the user wants to catch. This
12406 assumes that this condition is used when the inferior just triggered
12407 an exception catchpoint.
12408
12409 The string returned is a newly allocated string that needs to be
12410 deallocated later. */
12411
12412static char *
28010a5d 12413ada_exception_catchpoint_cond_string (const char *excep_string)
f7f9143b 12414{
3d0b0fa3
JB
12415 int i;
12416
0963b4bd 12417 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 12418 runtime units that have been compiled without debugging info; if
28010a5d 12419 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
12420 exception (e.g. "constraint_error") then, during the evaluation
12421 of the condition expression, the symbol lookup on this name would
0963b4bd 12422 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
12423 may then be set only on user-defined exceptions which have the
12424 same not-fully-qualified name (e.g. my_package.constraint_error).
12425
12426 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 12427 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
12428 exception constraint_error" is rewritten into "catch exception
12429 standard.constraint_error".
12430
12431 If an exception named contraint_error is defined in another package of
12432 the inferior program, then the only way to specify this exception as a
12433 breakpoint condition is to use its fully-qualified named:
12434 e.g. my_package.constraint_error. */
12435
12436 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12437 {
28010a5d 12438 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3
JB
12439 {
12440 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
28010a5d 12441 excep_string);
3d0b0fa3
JB
12442 }
12443 }
28010a5d 12444 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
f7f9143b
JB
12445}
12446
12447/* Return the symtab_and_line that should be used to insert an exception
12448 catchpoint of the TYPE kind.
12449
28010a5d
PA
12450 EXCEP_STRING should contain the name of a specific exception that
12451 the catchpoint should catch, or NULL otherwise.
f7f9143b 12452
28010a5d
PA
12453 ADDR_STRING returns the name of the function where the real
12454 breakpoint that implements the catchpoints is set, depending on the
12455 type of catchpoint we need to create. */
f7f9143b
JB
12456
12457static struct symtab_and_line
761269c8 12458ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
c0a91b2b 12459 char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
12460{
12461 const char *sym_name;
12462 struct symbol *sym;
f7f9143b 12463
0259addd
JB
12464 /* First, find out which exception support info to use. */
12465 ada_exception_support_info_sniffer ();
12466
12467 /* Then lookup the function on which we will break in order to catch
f7f9143b 12468 the Ada exceptions requested by the user. */
f7f9143b
JB
12469 sym_name = ada_exception_sym_name (ex);
12470 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12471
f17011e0
JB
12472 /* We can assume that SYM is not NULL at this stage. If the symbol
12473 did not exist, ada_exception_support_info_sniffer would have
12474 raised an exception.
f7f9143b 12475
f17011e0
JB
12476 Also, ada_exception_support_info_sniffer should have already
12477 verified that SYM is a function symbol. */
12478 gdb_assert (sym != NULL);
12479 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
12480
12481 /* Set ADDR_STRING. */
f7f9143b
JB
12482 *addr_string = xstrdup (sym_name);
12483
f7f9143b 12484 /* Set OPS. */
4b9eee8c 12485 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 12486
f17011e0 12487 return find_function_start_sal (sym, 1);
f7f9143b
JB
12488}
12489
b4a5b78b 12490/* Create an Ada exception catchpoint.
f7f9143b 12491
b4a5b78b 12492 EX_KIND is the kind of exception catchpoint to be created.
5845583d 12493
2df4d1d5
JB
12494 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
12495 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12496 of the exception to which this catchpoint applies. When not NULL,
12497 the string must be allocated on the heap, and its deallocation
12498 is no longer the responsibility of the caller.
12499
12500 COND_STRING, if not NULL, is the catchpoint condition. This string
12501 must be allocated on the heap, and its deallocation is no longer
12502 the responsibility of the caller.
f7f9143b 12503
b4a5b78b
JB
12504 TEMPFLAG, if nonzero, means that the underlying breakpoint
12505 should be temporary.
28010a5d 12506
b4a5b78b 12507 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 12508
349774ef 12509void
28010a5d 12510create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 12511 enum ada_exception_catchpoint_kind ex_kind,
28010a5d 12512 char *excep_string,
5845583d 12513 char *cond_string,
28010a5d 12514 int tempflag,
349774ef 12515 int disabled,
28010a5d
PA
12516 int from_tty)
12517{
12518 struct ada_catchpoint *c;
b4a5b78b
JB
12519 char *addr_string = NULL;
12520 const struct breakpoint_ops *ops = NULL;
12521 struct symtab_and_line sal
12522 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
28010a5d
PA
12523
12524 c = XNEW (struct ada_catchpoint);
12525 init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string,
349774ef 12526 ops, tempflag, disabled, from_tty);
28010a5d
PA
12527 c->excep_string = excep_string;
12528 create_excep_cond_exprs (c);
5845583d
JB
12529 if (cond_string != NULL)
12530 set_breakpoint_condition (&c->base, cond_string, from_tty);
3ea46bff 12531 install_breakpoint (0, &c->base, 1);
f7f9143b
JB
12532}
12533
9ac4176b
PA
12534/* Implement the "catch exception" command. */
12535
12536static void
12537catch_ada_exception_command (char *arg, int from_tty,
12538 struct cmd_list_element *command)
12539{
12540 struct gdbarch *gdbarch = get_current_arch ();
12541 int tempflag;
761269c8 12542 enum ada_exception_catchpoint_kind ex_kind;
28010a5d 12543 char *excep_string = NULL;
5845583d 12544 char *cond_string = NULL;
9ac4176b
PA
12545
12546 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12547
12548 if (!arg)
12549 arg = "";
b4a5b78b
JB
12550 catch_ada_exception_command_split (arg, &ex_kind, &excep_string,
12551 &cond_string);
12552 create_ada_exception_catchpoint (gdbarch, ex_kind,
12553 excep_string, cond_string,
349774ef
JB
12554 tempflag, 1 /* enabled */,
12555 from_tty);
9ac4176b
PA
12556}
12557
b4a5b78b 12558/* Split the arguments specified in a "catch assert" command.
5845583d 12559
b4a5b78b
JB
12560 ARGS contains the command's arguments (or the empty string if
12561 no arguments were passed).
5845583d
JB
12562
12563 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 12564 (the memory needs to be deallocated after use). */
5845583d 12565
b4a5b78b
JB
12566static void
12567catch_ada_assert_command_split (char *args, char **cond_string)
f7f9143b 12568{
5845583d 12569 args = skip_spaces (args);
f7f9143b 12570
5845583d
JB
12571 /* Check whether a condition was provided. */
12572 if (strncmp (args, "if", 2) == 0
12573 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 12574 {
5845583d 12575 args += 2;
0fcd72ba 12576 args = skip_spaces (args);
5845583d
JB
12577 if (args[0] == '\0')
12578 error (_("condition missing after `if' keyword"));
12579 *cond_string = xstrdup (args);
f7f9143b
JB
12580 }
12581
5845583d
JB
12582 /* Otherwise, there should be no other argument at the end of
12583 the command. */
12584 else if (args[0] != '\0')
12585 error (_("Junk at end of arguments."));
f7f9143b
JB
12586}
12587
9ac4176b
PA
12588/* Implement the "catch assert" command. */
12589
12590static void
12591catch_assert_command (char *arg, int from_tty,
12592 struct cmd_list_element *command)
12593{
12594 struct gdbarch *gdbarch = get_current_arch ();
12595 int tempflag;
5845583d 12596 char *cond_string = NULL;
9ac4176b
PA
12597
12598 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12599
12600 if (!arg)
12601 arg = "";
b4a5b78b 12602 catch_ada_assert_command_split (arg, &cond_string);
761269c8 12603 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
b4a5b78b 12604 NULL, cond_string,
349774ef
JB
12605 tempflag, 1 /* enabled */,
12606 from_tty);
9ac4176b 12607}
778865d3
JB
12608
12609/* Return non-zero if the symbol SYM is an Ada exception object. */
12610
12611static int
12612ada_is_exception_sym (struct symbol *sym)
12613{
12614 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
12615
12616 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
12617 && SYMBOL_CLASS (sym) != LOC_BLOCK
12618 && SYMBOL_CLASS (sym) != LOC_CONST
12619 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
12620 && type_name != NULL && strcmp (type_name, "exception") == 0);
12621}
12622
12623/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12624 Ada exception object. This matches all exceptions except the ones
12625 defined by the Ada language. */
12626
12627static int
12628ada_is_non_standard_exception_sym (struct symbol *sym)
12629{
12630 int i;
12631
12632 if (!ada_is_exception_sym (sym))
12633 return 0;
12634
12635 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12636 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
12637 return 0; /* A standard exception. */
12638
12639 /* Numeric_Error is also a standard exception, so exclude it.
12640 See the STANDARD_EXC description for more details as to why
12641 this exception is not listed in that array. */
12642 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
12643 return 0;
12644
12645 return 1;
12646}
12647
12648/* A helper function for qsort, comparing two struct ada_exc_info
12649 objects.
12650
12651 The comparison is determined first by exception name, and then
12652 by exception address. */
12653
12654static int
12655compare_ada_exception_info (const void *a, const void *b)
12656{
12657 const struct ada_exc_info *exc_a = (struct ada_exc_info *) a;
12658 const struct ada_exc_info *exc_b = (struct ada_exc_info *) b;
12659 int result;
12660
12661 result = strcmp (exc_a->name, exc_b->name);
12662 if (result != 0)
12663 return result;
12664
12665 if (exc_a->addr < exc_b->addr)
12666 return -1;
12667 if (exc_a->addr > exc_b->addr)
12668 return 1;
12669
12670 return 0;
12671}
12672
12673/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12674 routine, but keeping the first SKIP elements untouched.
12675
12676 All duplicates are also removed. */
12677
12678static void
12679sort_remove_dups_ada_exceptions_list (VEC(ada_exc_info) **exceptions,
12680 int skip)
12681{
12682 struct ada_exc_info *to_sort
12683 = VEC_address (ada_exc_info, *exceptions) + skip;
12684 int to_sort_len
12685 = VEC_length (ada_exc_info, *exceptions) - skip;
12686 int i, j;
12687
12688 qsort (to_sort, to_sort_len, sizeof (struct ada_exc_info),
12689 compare_ada_exception_info);
12690
12691 for (i = 1, j = 1; i < to_sort_len; i++)
12692 if (compare_ada_exception_info (&to_sort[i], &to_sort[j - 1]) != 0)
12693 to_sort[j++] = to_sort[i];
12694 to_sort_len = j;
12695 VEC_truncate(ada_exc_info, *exceptions, skip + to_sort_len);
12696}
12697
12698/* A function intended as the "name_matcher" callback in the struct
12699 quick_symbol_functions' expand_symtabs_matching method.
12700
12701 SEARCH_NAME is the symbol's search name.
12702
12703 If USER_DATA is not NULL, it is a pointer to a regext_t object
12704 used to match the symbol (by natural name). Otherwise, when USER_DATA
12705 is null, no filtering is performed, and all symbols are a positive
12706 match. */
12707
12708static int
12709ada_exc_search_name_matches (const char *search_name, void *user_data)
12710{
12711 regex_t *preg = user_data;
12712
12713 if (preg == NULL)
12714 return 1;
12715
12716 /* In Ada, the symbol "search name" is a linkage name, whereas
12717 the regular expression used to do the matching refers to
12718 the natural name. So match against the decoded name. */
12719 return (regexec (preg, ada_decode (search_name), 0, NULL, 0) == 0);
12720}
12721
12722/* Add all exceptions defined by the Ada standard whose name match
12723 a regular expression.
12724
12725 If PREG is not NULL, then this regexp_t object is used to
12726 perform the symbol name matching. Otherwise, no name-based
12727 filtering is performed.
12728
12729 EXCEPTIONS is a vector of exceptions to which matching exceptions
12730 gets pushed. */
12731
12732static void
12733ada_add_standard_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
12734{
12735 int i;
12736
12737 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12738 {
12739 if (preg == NULL
12740 || regexec (preg, standard_exc[i], 0, NULL, 0) == 0)
12741 {
12742 struct bound_minimal_symbol msymbol
12743 = ada_lookup_simple_minsym (standard_exc[i]);
12744
12745 if (msymbol.minsym != NULL)
12746 {
12747 struct ada_exc_info info
77e371c0 12748 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
778865d3
JB
12749
12750 VEC_safe_push (ada_exc_info, *exceptions, &info);
12751 }
12752 }
12753 }
12754}
12755
12756/* Add all Ada exceptions defined locally and accessible from the given
12757 FRAME.
12758
12759 If PREG is not NULL, then this regexp_t object is used to
12760 perform the symbol name matching. Otherwise, no name-based
12761 filtering is performed.
12762
12763 EXCEPTIONS is a vector of exceptions to which matching exceptions
12764 gets pushed. */
12765
12766static void
12767ada_add_exceptions_from_frame (regex_t *preg, struct frame_info *frame,
12768 VEC(ada_exc_info) **exceptions)
12769{
12770 struct block *block = get_frame_block (frame, 0);
12771
12772 while (block != 0)
12773 {
12774 struct block_iterator iter;
12775 struct symbol *sym;
12776
12777 ALL_BLOCK_SYMBOLS (block, iter, sym)
12778 {
12779 switch (SYMBOL_CLASS (sym))
12780 {
12781 case LOC_TYPEDEF:
12782 case LOC_BLOCK:
12783 case LOC_CONST:
12784 break;
12785 default:
12786 if (ada_is_exception_sym (sym))
12787 {
12788 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
12789 SYMBOL_VALUE_ADDRESS (sym)};
12790
12791 VEC_safe_push (ada_exc_info, *exceptions, &info);
12792 }
12793 }
12794 }
12795 if (BLOCK_FUNCTION (block) != NULL)
12796 break;
12797 block = BLOCK_SUPERBLOCK (block);
12798 }
12799}
12800
12801/* Add all exceptions defined globally whose name name match
12802 a regular expression, excluding standard exceptions.
12803
12804 The reason we exclude standard exceptions is that they need
12805 to be handled separately: Standard exceptions are defined inside
12806 a runtime unit which is normally not compiled with debugging info,
12807 and thus usually do not show up in our symbol search. However,
12808 if the unit was in fact built with debugging info, we need to
12809 exclude them because they would duplicate the entry we found
12810 during the special loop that specifically searches for those
12811 standard exceptions.
12812
12813 If PREG is not NULL, then this regexp_t object is used to
12814 perform the symbol name matching. Otherwise, no name-based
12815 filtering is performed.
12816
12817 EXCEPTIONS is a vector of exceptions to which matching exceptions
12818 gets pushed. */
12819
12820static void
12821ada_add_global_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
12822{
12823 struct objfile *objfile;
12824 struct symtab *s;
12825
bb4142cf
DE
12826 expand_symtabs_matching (NULL, ada_exc_search_name_matches,
12827 VARIABLES_DOMAIN, preg);
778865d3
JB
12828
12829 ALL_PRIMARY_SYMTABS (objfile, s)
12830 {
12831 struct blockvector *bv = BLOCKVECTOR (s);
12832 int i;
12833
12834 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
12835 {
12836 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
12837 struct block_iterator iter;
12838 struct symbol *sym;
12839
12840 ALL_BLOCK_SYMBOLS (b, iter, sym)
12841 if (ada_is_non_standard_exception_sym (sym)
12842 && (preg == NULL
12843 || regexec (preg, SYMBOL_NATURAL_NAME (sym),
12844 0, NULL, 0) == 0))
12845 {
12846 struct ada_exc_info info
12847 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
12848
12849 VEC_safe_push (ada_exc_info, *exceptions, &info);
12850 }
12851 }
12852 }
12853}
12854
12855/* Implements ada_exceptions_list with the regular expression passed
12856 as a regex_t, rather than a string.
12857
12858 If not NULL, PREG is used to filter out exceptions whose names
12859 do not match. Otherwise, all exceptions are listed. */
12860
12861static VEC(ada_exc_info) *
12862ada_exceptions_list_1 (regex_t *preg)
12863{
12864 VEC(ada_exc_info) *result = NULL;
12865 struct cleanup *old_chain
12866 = make_cleanup (VEC_cleanup (ada_exc_info), &result);
12867 int prev_len;
12868
12869 /* First, list the known standard exceptions. These exceptions
12870 need to be handled separately, as they are usually defined in
12871 runtime units that have been compiled without debugging info. */
12872
12873 ada_add_standard_exceptions (preg, &result);
12874
12875 /* Next, find all exceptions whose scope is local and accessible
12876 from the currently selected frame. */
12877
12878 if (has_stack_frames ())
12879 {
12880 prev_len = VEC_length (ada_exc_info, result);
12881 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
12882 &result);
12883 if (VEC_length (ada_exc_info, result) > prev_len)
12884 sort_remove_dups_ada_exceptions_list (&result, prev_len);
12885 }
12886
12887 /* Add all exceptions whose scope is global. */
12888
12889 prev_len = VEC_length (ada_exc_info, result);
12890 ada_add_global_exceptions (preg, &result);
12891 if (VEC_length (ada_exc_info, result) > prev_len)
12892 sort_remove_dups_ada_exceptions_list (&result, prev_len);
12893
12894 discard_cleanups (old_chain);
12895 return result;
12896}
12897
12898/* Return a vector of ada_exc_info.
12899
12900 If REGEXP is NULL, all exceptions are included in the result.
12901 Otherwise, it should contain a valid regular expression,
12902 and only the exceptions whose names match that regular expression
12903 are included in the result.
12904
12905 The exceptions are sorted in the following order:
12906 - Standard exceptions (defined by the Ada language), in
12907 alphabetical order;
12908 - Exceptions only visible from the current frame, in
12909 alphabetical order;
12910 - Exceptions whose scope is global, in alphabetical order. */
12911
12912VEC(ada_exc_info) *
12913ada_exceptions_list (const char *regexp)
12914{
12915 VEC(ada_exc_info) *result = NULL;
12916 struct cleanup *old_chain = NULL;
12917 regex_t reg;
12918
12919 if (regexp != NULL)
12920 old_chain = compile_rx_or_error (&reg, regexp,
12921 _("invalid regular expression"));
12922
12923 result = ada_exceptions_list_1 (regexp != NULL ? &reg : NULL);
12924
12925 if (old_chain != NULL)
12926 do_cleanups (old_chain);
12927 return result;
12928}
12929
12930/* Implement the "info exceptions" command. */
12931
12932static void
12933info_exceptions_command (char *regexp, int from_tty)
12934{
12935 VEC(ada_exc_info) *exceptions;
12936 struct cleanup *cleanup;
12937 struct gdbarch *gdbarch = get_current_arch ();
12938 int ix;
12939 struct ada_exc_info *info;
12940
12941 exceptions = ada_exceptions_list (regexp);
12942 cleanup = make_cleanup (VEC_cleanup (ada_exc_info), &exceptions);
12943
12944 if (regexp != NULL)
12945 printf_filtered
12946 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
12947 else
12948 printf_filtered (_("All defined Ada exceptions:\n"));
12949
12950 for (ix = 0; VEC_iterate(ada_exc_info, exceptions, ix, info); ix++)
12951 printf_filtered ("%s: %s\n", info->name, paddress (gdbarch, info->addr));
12952
12953 do_cleanups (cleanup);
12954}
12955
4c4b4cd2
PH
12956 /* Operators */
12957/* Information about operators given special treatment in functions
12958 below. */
12959/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
12960
12961#define ADA_OPERATORS \
12962 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
12963 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
12964 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
12965 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
12966 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
12967 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
12968 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
12969 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
12970 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
12971 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
12972 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
12973 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
12974 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
12975 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
12976 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
12977 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
12978 OP_DEFN (OP_OTHERS, 1, 1, 0) \
12979 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
12980 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
12981
12982static void
554794dc
SDJ
12983ada_operator_length (const struct expression *exp, int pc, int *oplenp,
12984 int *argsp)
4c4b4cd2
PH
12985{
12986 switch (exp->elts[pc - 1].opcode)
12987 {
76a01679 12988 default:
4c4b4cd2
PH
12989 operator_length_standard (exp, pc, oplenp, argsp);
12990 break;
12991
12992#define OP_DEFN(op, len, args, binop) \
12993 case op: *oplenp = len; *argsp = args; break;
12994 ADA_OPERATORS;
12995#undef OP_DEFN
52ce6436
PH
12996
12997 case OP_AGGREGATE:
12998 *oplenp = 3;
12999 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13000 break;
13001
13002 case OP_CHOICES:
13003 *oplenp = 3;
13004 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13005 break;
4c4b4cd2
PH
13006 }
13007}
13008
c0201579
JK
13009/* Implementation of the exp_descriptor method operator_check. */
13010
13011static int
13012ada_operator_check (struct expression *exp, int pos,
13013 int (*objfile_func) (struct objfile *objfile, void *data),
13014 void *data)
13015{
13016 const union exp_element *const elts = exp->elts;
13017 struct type *type = NULL;
13018
13019 switch (elts[pos].opcode)
13020 {
13021 case UNOP_IN_RANGE:
13022 case UNOP_QUAL:
13023 type = elts[pos + 1].type;
13024 break;
13025
13026 default:
13027 return operator_check_standard (exp, pos, objfile_func, data);
13028 }
13029
13030 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13031
13032 if (type && TYPE_OBJFILE (type)
13033 && (*objfile_func) (TYPE_OBJFILE (type), data))
13034 return 1;
13035
13036 return 0;
13037}
13038
4c4b4cd2
PH
13039static char *
13040ada_op_name (enum exp_opcode opcode)
13041{
13042 switch (opcode)
13043 {
76a01679 13044 default:
4c4b4cd2 13045 return op_name_standard (opcode);
52ce6436 13046
4c4b4cd2
PH
13047#define OP_DEFN(op, len, args, binop) case op: return #op;
13048 ADA_OPERATORS;
13049#undef OP_DEFN
52ce6436
PH
13050
13051 case OP_AGGREGATE:
13052 return "OP_AGGREGATE";
13053 case OP_CHOICES:
13054 return "OP_CHOICES";
13055 case OP_NAME:
13056 return "OP_NAME";
4c4b4cd2
PH
13057 }
13058}
13059
13060/* As for operator_length, but assumes PC is pointing at the first
13061 element of the operator, and gives meaningful results only for the
52ce6436 13062 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
13063
13064static void
76a01679
JB
13065ada_forward_operator_length (struct expression *exp, int pc,
13066 int *oplenp, int *argsp)
4c4b4cd2 13067{
76a01679 13068 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
13069 {
13070 default:
13071 *oplenp = *argsp = 0;
13072 break;
52ce6436 13073
4c4b4cd2
PH
13074#define OP_DEFN(op, len, args, binop) \
13075 case op: *oplenp = len; *argsp = args; break;
13076 ADA_OPERATORS;
13077#undef OP_DEFN
52ce6436
PH
13078
13079 case OP_AGGREGATE:
13080 *oplenp = 3;
13081 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13082 break;
13083
13084 case OP_CHOICES:
13085 *oplenp = 3;
13086 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13087 break;
13088
13089 case OP_STRING:
13090 case OP_NAME:
13091 {
13092 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13093
52ce6436
PH
13094 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13095 *argsp = 0;
13096 break;
13097 }
4c4b4cd2
PH
13098 }
13099}
13100
13101static int
13102ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13103{
13104 enum exp_opcode op = exp->elts[elt].opcode;
13105 int oplen, nargs;
13106 int pc = elt;
13107 int i;
76a01679 13108
4c4b4cd2
PH
13109 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13110
76a01679 13111 switch (op)
4c4b4cd2 13112 {
76a01679 13113 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13114 case OP_ATR_FIRST:
13115 case OP_ATR_LAST:
13116 case OP_ATR_LENGTH:
13117 case OP_ATR_IMAGE:
13118 case OP_ATR_MAX:
13119 case OP_ATR_MIN:
13120 case OP_ATR_MODULUS:
13121 case OP_ATR_POS:
13122 case OP_ATR_SIZE:
13123 case OP_ATR_TAG:
13124 case OP_ATR_VAL:
13125 break;
13126
13127 case UNOP_IN_RANGE:
13128 case UNOP_QUAL:
323e0a4a
AC
13129 /* XXX: gdb_sprint_host_address, type_sprint */
13130 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13131 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13132 fprintf_filtered (stream, " (");
13133 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13134 fprintf_filtered (stream, ")");
13135 break;
13136 case BINOP_IN_BOUNDS:
52ce6436
PH
13137 fprintf_filtered (stream, " (%d)",
13138 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13139 break;
13140 case TERNOP_IN_RANGE:
13141 break;
13142
52ce6436
PH
13143 case OP_AGGREGATE:
13144 case OP_OTHERS:
13145 case OP_DISCRETE_RANGE:
13146 case OP_POSITIONAL:
13147 case OP_CHOICES:
13148 break;
13149
13150 case OP_NAME:
13151 case OP_STRING:
13152 {
13153 char *name = &exp->elts[elt + 2].string;
13154 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 13155
52ce6436
PH
13156 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13157 break;
13158 }
13159
4c4b4cd2
PH
13160 default:
13161 return dump_subexp_body_standard (exp, stream, elt);
13162 }
13163
13164 elt += oplen;
13165 for (i = 0; i < nargs; i += 1)
13166 elt = dump_subexp (exp, stream, elt);
13167
13168 return elt;
13169}
13170
13171/* The Ada extension of print_subexp (q.v.). */
13172
76a01679
JB
13173static void
13174ada_print_subexp (struct expression *exp, int *pos,
13175 struct ui_file *stream, enum precedence prec)
4c4b4cd2 13176{
52ce6436 13177 int oplen, nargs, i;
4c4b4cd2
PH
13178 int pc = *pos;
13179 enum exp_opcode op = exp->elts[pc].opcode;
13180
13181 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13182
52ce6436 13183 *pos += oplen;
4c4b4cd2
PH
13184 switch (op)
13185 {
13186 default:
52ce6436 13187 *pos -= oplen;
4c4b4cd2
PH
13188 print_subexp_standard (exp, pos, stream, prec);
13189 return;
13190
13191 case OP_VAR_VALUE:
4c4b4cd2
PH
13192 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13193 return;
13194
13195 case BINOP_IN_BOUNDS:
323e0a4a 13196 /* XXX: sprint_subexp */
4c4b4cd2 13197 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13198 fputs_filtered (" in ", stream);
4c4b4cd2 13199 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13200 fputs_filtered ("'range", stream);
4c4b4cd2 13201 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
13202 fprintf_filtered (stream, "(%ld)",
13203 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
13204 return;
13205
13206 case TERNOP_IN_RANGE:
4c4b4cd2 13207 if (prec >= PREC_EQUAL)
76a01679 13208 fputs_filtered ("(", stream);
323e0a4a 13209 /* XXX: sprint_subexp */
4c4b4cd2 13210 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13211 fputs_filtered (" in ", stream);
4c4b4cd2
PH
13212 print_subexp (exp, pos, stream, PREC_EQUAL);
13213 fputs_filtered (" .. ", stream);
13214 print_subexp (exp, pos, stream, PREC_EQUAL);
13215 if (prec >= PREC_EQUAL)
76a01679
JB
13216 fputs_filtered (")", stream);
13217 return;
4c4b4cd2
PH
13218
13219 case OP_ATR_FIRST:
13220 case OP_ATR_LAST:
13221 case OP_ATR_LENGTH:
13222 case OP_ATR_IMAGE:
13223 case OP_ATR_MAX:
13224 case OP_ATR_MIN:
13225 case OP_ATR_MODULUS:
13226 case OP_ATR_POS:
13227 case OP_ATR_SIZE:
13228 case OP_ATR_TAG:
13229 case OP_ATR_VAL:
4c4b4cd2 13230 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
13231 {
13232 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
13233 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13234 &type_print_raw_options);
76a01679
JB
13235 *pos += 3;
13236 }
4c4b4cd2 13237 else
76a01679 13238 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
13239 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13240 if (nargs > 1)
76a01679
JB
13241 {
13242 int tem;
5b4ee69b 13243
76a01679
JB
13244 for (tem = 1; tem < nargs; tem += 1)
13245 {
13246 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13247 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13248 }
13249 fputs_filtered (")", stream);
13250 }
4c4b4cd2 13251 return;
14f9c5c9 13252
4c4b4cd2 13253 case UNOP_QUAL:
4c4b4cd2
PH
13254 type_print (exp->elts[pc + 1].type, "", stream, 0);
13255 fputs_filtered ("'(", stream);
13256 print_subexp (exp, pos, stream, PREC_PREFIX);
13257 fputs_filtered (")", stream);
13258 return;
14f9c5c9 13259
4c4b4cd2 13260 case UNOP_IN_RANGE:
323e0a4a 13261 /* XXX: sprint_subexp */
4c4b4cd2 13262 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13263 fputs_filtered (" in ", stream);
79d43c61
TT
13264 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13265 &type_print_raw_options);
4c4b4cd2 13266 return;
52ce6436
PH
13267
13268 case OP_DISCRETE_RANGE:
13269 print_subexp (exp, pos, stream, PREC_SUFFIX);
13270 fputs_filtered ("..", stream);
13271 print_subexp (exp, pos, stream, PREC_SUFFIX);
13272 return;
13273
13274 case OP_OTHERS:
13275 fputs_filtered ("others => ", stream);
13276 print_subexp (exp, pos, stream, PREC_SUFFIX);
13277 return;
13278
13279 case OP_CHOICES:
13280 for (i = 0; i < nargs-1; i += 1)
13281 {
13282 if (i > 0)
13283 fputs_filtered ("|", stream);
13284 print_subexp (exp, pos, stream, PREC_SUFFIX);
13285 }
13286 fputs_filtered (" => ", stream);
13287 print_subexp (exp, pos, stream, PREC_SUFFIX);
13288 return;
13289
13290 case OP_POSITIONAL:
13291 print_subexp (exp, pos, stream, PREC_SUFFIX);
13292 return;
13293
13294 case OP_AGGREGATE:
13295 fputs_filtered ("(", stream);
13296 for (i = 0; i < nargs; i += 1)
13297 {
13298 if (i > 0)
13299 fputs_filtered (", ", stream);
13300 print_subexp (exp, pos, stream, PREC_SUFFIX);
13301 }
13302 fputs_filtered (")", stream);
13303 return;
4c4b4cd2
PH
13304 }
13305}
14f9c5c9
AS
13306
13307/* Table mapping opcodes into strings for printing operators
13308 and precedences of the operators. */
13309
d2e4a39e
AS
13310static const struct op_print ada_op_print_tab[] = {
13311 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13312 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13313 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13314 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13315 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13316 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13317 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13318 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13319 {"<=", BINOP_LEQ, PREC_ORDER, 0},
13320 {">=", BINOP_GEQ, PREC_ORDER, 0},
13321 {">", BINOP_GTR, PREC_ORDER, 0},
13322 {"<", BINOP_LESS, PREC_ORDER, 0},
13323 {">>", BINOP_RSH, PREC_SHIFT, 0},
13324 {"<<", BINOP_LSH, PREC_SHIFT, 0},
13325 {"+", BINOP_ADD, PREC_ADD, 0},
13326 {"-", BINOP_SUB, PREC_ADD, 0},
13327 {"&", BINOP_CONCAT, PREC_ADD, 0},
13328 {"*", BINOP_MUL, PREC_MUL, 0},
13329 {"/", BINOP_DIV, PREC_MUL, 0},
13330 {"rem", BINOP_REM, PREC_MUL, 0},
13331 {"mod", BINOP_MOD, PREC_MUL, 0},
13332 {"**", BINOP_EXP, PREC_REPEAT, 0},
13333 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13334 {"-", UNOP_NEG, PREC_PREFIX, 0},
13335 {"+", UNOP_PLUS, PREC_PREFIX, 0},
13336 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13337 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13338 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
13339 {".all", UNOP_IND, PREC_SUFFIX, 1},
13340 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13341 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
d2e4a39e 13342 {NULL, 0, 0, 0}
14f9c5c9
AS
13343};
13344\f
72d5681a
PH
13345enum ada_primitive_types {
13346 ada_primitive_type_int,
13347 ada_primitive_type_long,
13348 ada_primitive_type_short,
13349 ada_primitive_type_char,
13350 ada_primitive_type_float,
13351 ada_primitive_type_double,
13352 ada_primitive_type_void,
13353 ada_primitive_type_long_long,
13354 ada_primitive_type_long_double,
13355 ada_primitive_type_natural,
13356 ada_primitive_type_positive,
13357 ada_primitive_type_system_address,
13358 nr_ada_primitive_types
13359};
6c038f32
PH
13360
13361static void
d4a9a881 13362ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
13363 struct language_arch_info *lai)
13364{
d4a9a881 13365 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 13366
72d5681a 13367 lai->primitive_type_vector
d4a9a881 13368 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 13369 struct type *);
e9bb382b
UW
13370
13371 lai->primitive_type_vector [ada_primitive_type_int]
13372 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13373 0, "integer");
13374 lai->primitive_type_vector [ada_primitive_type_long]
13375 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13376 0, "long_integer");
13377 lai->primitive_type_vector [ada_primitive_type_short]
13378 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13379 0, "short_integer");
13380 lai->string_char_type
13381 = lai->primitive_type_vector [ada_primitive_type_char]
13382 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
13383 lai->primitive_type_vector [ada_primitive_type_float]
13384 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13385 "float", NULL);
13386 lai->primitive_type_vector [ada_primitive_type_double]
13387 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13388 "long_float", NULL);
13389 lai->primitive_type_vector [ada_primitive_type_long_long]
13390 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13391 0, "long_long_integer");
13392 lai->primitive_type_vector [ada_primitive_type_long_double]
13393 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13394 "long_long_float", NULL);
13395 lai->primitive_type_vector [ada_primitive_type_natural]
13396 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13397 0, "natural");
13398 lai->primitive_type_vector [ada_primitive_type_positive]
13399 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13400 0, "positive");
13401 lai->primitive_type_vector [ada_primitive_type_void]
13402 = builtin->builtin_void;
13403
13404 lai->primitive_type_vector [ada_primitive_type_system_address]
13405 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
72d5681a
PH
13406 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
13407 = "system__address";
fbb06eb1 13408
47e729a8 13409 lai->bool_type_symbol = NULL;
fbb06eb1 13410 lai->bool_type_default = builtin->builtin_bool;
6c038f32 13411}
6c038f32
PH
13412\f
13413 /* Language vector */
13414
13415/* Not really used, but needed in the ada_language_defn. */
13416
13417static void
6c7a06a3 13418emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 13419{
6c7a06a3 13420 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
13421}
13422
13423static int
410a0ff2 13424parse (struct parser_state *ps)
6c038f32
PH
13425{
13426 warnings_issued = 0;
410a0ff2 13427 return ada_parse (ps);
6c038f32
PH
13428}
13429
13430static const struct exp_descriptor ada_exp_descriptor = {
13431 ada_print_subexp,
13432 ada_operator_length,
c0201579 13433 ada_operator_check,
6c038f32
PH
13434 ada_op_name,
13435 ada_dump_subexp_body,
13436 ada_evaluate_subexp
13437};
13438
1a119f36 13439/* Implement the "la_get_symbol_name_cmp" language_defn method
74ccd7f5
JB
13440 for Ada. */
13441
1a119f36
JB
13442static symbol_name_cmp_ftype
13443ada_get_symbol_name_cmp (const char *lookup_name)
74ccd7f5
JB
13444{
13445 if (should_use_wild_match (lookup_name))
13446 return wild_match;
13447 else
13448 return compare_names;
13449}
13450
a5ee536b
JB
13451/* Implement the "la_read_var_value" language_defn method for Ada. */
13452
13453static struct value *
13454ada_read_var_value (struct symbol *var, struct frame_info *frame)
13455{
13456 struct block *frame_block = NULL;
13457 struct symbol *renaming_sym = NULL;
13458
13459 /* The only case where default_read_var_value is not sufficient
13460 is when VAR is a renaming... */
13461 if (frame)
13462 frame_block = get_frame_block (frame, NULL);
13463 if (frame_block)
13464 renaming_sym = ada_find_renaming_symbol (var, frame_block);
13465 if (renaming_sym != NULL)
13466 return ada_read_renaming_var_value (renaming_sym, frame_block);
13467
13468 /* This is a typical case where we expect the default_read_var_value
13469 function to work. */
13470 return default_read_var_value (var, frame);
13471}
13472
6c038f32
PH
13473const struct language_defn ada_language_defn = {
13474 "ada", /* Language name */
6abde28f 13475 "Ada",
6c038f32 13476 language_ada,
6c038f32 13477 range_check_off,
6c038f32
PH
13478 case_sensitive_on, /* Yes, Ada is case-insensitive, but
13479 that's not quite what this means. */
6c038f32 13480 array_row_major,
9a044a89 13481 macro_expansion_no,
6c038f32
PH
13482 &ada_exp_descriptor,
13483 parse,
13484 ada_error,
13485 resolve,
13486 ada_printchar, /* Print a character constant */
13487 ada_printstr, /* Function to print string constant */
13488 emit_char, /* Function to print single char (not used) */
6c038f32 13489 ada_print_type, /* Print a type using appropriate syntax */
be942545 13490 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
13491 ada_val_print, /* Print a value using appropriate syntax */
13492 ada_value_print, /* Print a top-level value */
a5ee536b 13493 ada_read_var_value, /* la_read_var_value */
6c038f32 13494 NULL, /* Language specific skip_trampoline */
2b2d9e11 13495 NULL, /* name_of_this */
6c038f32
PH
13496 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
13497 basic_lookup_transparent_type, /* lookup_transparent_type */
13498 ada_la_decode, /* Language specific symbol demangler */
0963b4bd
MS
13499 NULL, /* Language specific
13500 class_name_from_physname */
6c038f32
PH
13501 ada_op_print_tab, /* expression operators for printing */
13502 0, /* c-style arrays */
13503 1, /* String lower bound */
6c038f32 13504 ada_get_gdb_completer_word_break_characters,
41d27058 13505 ada_make_symbol_completion_list,
72d5681a 13506 ada_language_arch_info,
e79af960 13507 ada_print_array_index,
41f1b697 13508 default_pass_by_reference,
ae6a3a4c 13509 c_get_string,
1a119f36 13510 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
f8eba3c6 13511 ada_iterate_over_symbols,
a53b64ea 13512 &ada_varobj_ops,
6c038f32
PH
13513 LANG_MAGIC
13514};
13515
2c0b251b
PA
13516/* Provide a prototype to silence -Wmissing-prototypes. */
13517extern initialize_file_ftype _initialize_ada_language;
13518
5bf03f13
JB
13519/* Command-list for the "set/show ada" prefix command. */
13520static struct cmd_list_element *set_ada_list;
13521static struct cmd_list_element *show_ada_list;
13522
13523/* Implement the "set ada" prefix command. */
13524
13525static void
13526set_ada_command (char *arg, int from_tty)
13527{
13528 printf_unfiltered (_(\
13529"\"set ada\" must be followed by the name of a setting.\n"));
13530 help_list (set_ada_list, "set ada ", -1, gdb_stdout);
13531}
13532
13533/* Implement the "show ada" prefix command. */
13534
13535static void
13536show_ada_command (char *args, int from_tty)
13537{
13538 cmd_show_list (show_ada_list, from_tty, "");
13539}
13540
2060206e
PA
13541static void
13542initialize_ada_catchpoint_ops (void)
13543{
13544 struct breakpoint_ops *ops;
13545
13546 initialize_breakpoint_ops ();
13547
13548 ops = &catch_exception_breakpoint_ops;
13549 *ops = bkpt_breakpoint_ops;
13550 ops->dtor = dtor_catch_exception;
13551 ops->allocate_location = allocate_location_catch_exception;
13552 ops->re_set = re_set_catch_exception;
13553 ops->check_status = check_status_catch_exception;
13554 ops->print_it = print_it_catch_exception;
13555 ops->print_one = print_one_catch_exception;
13556 ops->print_mention = print_mention_catch_exception;
13557 ops->print_recreate = print_recreate_catch_exception;
13558
13559 ops = &catch_exception_unhandled_breakpoint_ops;
13560 *ops = bkpt_breakpoint_ops;
13561 ops->dtor = dtor_catch_exception_unhandled;
13562 ops->allocate_location = allocate_location_catch_exception_unhandled;
13563 ops->re_set = re_set_catch_exception_unhandled;
13564 ops->check_status = check_status_catch_exception_unhandled;
13565 ops->print_it = print_it_catch_exception_unhandled;
13566 ops->print_one = print_one_catch_exception_unhandled;
13567 ops->print_mention = print_mention_catch_exception_unhandled;
13568 ops->print_recreate = print_recreate_catch_exception_unhandled;
13569
13570 ops = &catch_assert_breakpoint_ops;
13571 *ops = bkpt_breakpoint_ops;
13572 ops->dtor = dtor_catch_assert;
13573 ops->allocate_location = allocate_location_catch_assert;
13574 ops->re_set = re_set_catch_assert;
13575 ops->check_status = check_status_catch_assert;
13576 ops->print_it = print_it_catch_assert;
13577 ops->print_one = print_one_catch_assert;
13578 ops->print_mention = print_mention_catch_assert;
13579 ops->print_recreate = print_recreate_catch_assert;
13580}
13581
3d9434b5
JB
13582/* This module's 'new_objfile' observer. */
13583
13584static void
13585ada_new_objfile_observer (struct objfile *objfile)
13586{
13587 ada_clear_symbol_cache ();
13588}
13589
13590/* This module's 'free_objfile' observer. */
13591
13592static void
13593ada_free_objfile_observer (struct objfile *objfile)
13594{
13595 ada_clear_symbol_cache ();
13596}
13597
d2e4a39e 13598void
6c038f32 13599_initialize_ada_language (void)
14f9c5c9 13600{
6c038f32
PH
13601 add_language (&ada_language_defn);
13602
2060206e
PA
13603 initialize_ada_catchpoint_ops ();
13604
5bf03f13
JB
13605 add_prefix_cmd ("ada", no_class, set_ada_command,
13606 _("Prefix command for changing Ada-specfic settings"),
13607 &set_ada_list, "set ada ", 0, &setlist);
13608
13609 add_prefix_cmd ("ada", no_class, show_ada_command,
13610 _("Generic command for showing Ada-specific settings."),
13611 &show_ada_list, "show ada ", 0, &showlist);
13612
13613 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13614 &trust_pad_over_xvs, _("\
13615Enable or disable an optimization trusting PAD types over XVS types"), _("\
13616Show whether an optimization trusting PAD types over XVS types is activated"),
13617 _("\
13618This is related to the encoding used by the GNAT compiler. The debugger\n\
13619should normally trust the contents of PAD types, but certain older versions\n\
13620of GNAT have a bug that sometimes causes the information in the PAD type\n\
13621to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13622work around this bug. It is always safe to turn this option \"off\", but\n\
13623this incurs a slight performance penalty, so it is recommended to NOT change\n\
13624this option to \"off\" unless necessary."),
13625 NULL, NULL, &set_ada_list, &show_ada_list);
13626
9ac4176b
PA
13627 add_catch_command ("exception", _("\
13628Catch Ada exceptions, when raised.\n\
13629With an argument, catch only exceptions with the given name."),
13630 catch_ada_exception_command,
13631 NULL,
13632 CATCH_PERMANENT,
13633 CATCH_TEMPORARY);
13634 add_catch_command ("assert", _("\
13635Catch failed Ada assertions, when raised.\n\
13636With an argument, catch only exceptions with the given name."),
13637 catch_assert_command,
13638 NULL,
13639 CATCH_PERMANENT,
13640 CATCH_TEMPORARY);
13641
6c038f32 13642 varsize_limit = 65536;
6c038f32 13643
778865d3
JB
13644 add_info ("exceptions", info_exceptions_command,
13645 _("\
13646List all Ada exception names.\n\
13647If a regular expression is passed as an argument, only those matching\n\
13648the regular expression are listed."));
13649
c6044dd1
JB
13650 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
13651 _("Set Ada maintenance-related variables."),
13652 &maint_set_ada_cmdlist, "maintenance set ada ",
13653 0/*allow-unknown*/, &maintenance_set_cmdlist);
13654
13655 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
13656 _("Show Ada maintenance-related variables"),
13657 &maint_show_ada_cmdlist, "maintenance show ada ",
13658 0/*allow-unknown*/, &maintenance_show_cmdlist);
13659
13660 add_setshow_boolean_cmd
13661 ("ignore-descriptive-types", class_maintenance,
13662 &ada_ignore_descriptive_types_p,
13663 _("Set whether descriptive types generated by GNAT should be ignored."),
13664 _("Show whether descriptive types generated by GNAT should be ignored."),
13665 _("\
13666When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13667DWARF attribute."),
13668 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
13669
6c038f32
PH
13670 obstack_init (&symbol_list_obstack);
13671
13672 decoded_names_store = htab_create_alloc
13673 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
13674 NULL, xcalloc, xfree);
6b69afc4 13675
3d9434b5
JB
13676 /* The ada-lang observers. */
13677 observer_attach_new_objfile (ada_new_objfile_observer);
13678 observer_attach_free_objfile (ada_free_objfile_observer);
e802dbe0 13679 observer_attach_inferior_exit (ada_inferior_exit);
ee01b665
JB
13680
13681 /* Setup various context-specific data. */
e802dbe0 13682 ada_inferior_data
8e260fc0 13683 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
ee01b665
JB
13684 ada_pspace_data_handle
13685 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14f9c5c9 13686}