]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blob - gdb/ada-lang.c
Make gdb.base/index-cache.exp work with readnow board (PR 24669)
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
1 /* Ada language support routines for GDB, the GNU debugger.
2
3 Copyright (C) 1992-2019 Free Software Foundation, Inc.
4
5 This file is part of GDB.
6
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.
11
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.
16
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/>. */
19
20
21 #include "defs.h"
22 #include <ctype.h>
23 #include "demangle.h"
24 #include "gdb_regex.h"
25 #include "frame.h"
26 #include "symtab.h"
27 #include "gdbtypes.h"
28 #include "gdbcmd.h"
29 #include "expression.h"
30 #include "parser-defs.h"
31 #include "language.h"
32 #include "varobj.h"
33 #include "c-lang.h"
34 #include "inferior.h"
35 #include "symfile.h"
36 #include "objfiles.h"
37 #include "breakpoint.h"
38 #include "gdbcore.h"
39 #include "hashtab.h"
40 #include "gdb_obstack.h"
41 #include "ada-lang.h"
42 #include "completer.h"
43 #include <sys/stat.h>
44 #include "ui-out.h"
45 #include "block.h"
46 #include "infcall.h"
47 #include "dictionary.h"
48 #include "annotate.h"
49 #include "valprint.h"
50 #include "source.h"
51 #include "observable.h"
52 #include "common/vec.h"
53 #include "stack.h"
54 #include "common/gdb_vecs.h"
55 #include "typeprint.h"
56 #include "namespace.h"
57
58 #include "psymtab.h"
59 #include "value.h"
60 #include "mi/mi-common.h"
61 #include "arch-utils.h"
62 #include "cli/cli-utils.h"
63 #include "common/function-view.h"
64 #include "common/byte-vector.h"
65 #include <algorithm>
66 #include <map>
67
68 /* Define whether or not the C operator '/' truncates towards zero for
69 differently signed operands (truncation direction is undefined in C).
70 Copied from valarith.c. */
71
72 #ifndef TRUNCATION_TOWARDS_ZERO
73 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
74 #endif
75
76 static struct type *desc_base_type (struct type *);
77
78 static struct type *desc_bounds_type (struct type *);
79
80 static struct value *desc_bounds (struct value *);
81
82 static int fat_pntr_bounds_bitpos (struct type *);
83
84 static int fat_pntr_bounds_bitsize (struct type *);
85
86 static struct type *desc_data_target_type (struct type *);
87
88 static struct value *desc_data (struct value *);
89
90 static int fat_pntr_data_bitpos (struct type *);
91
92 static int fat_pntr_data_bitsize (struct type *);
93
94 static struct value *desc_one_bound (struct value *, int, int);
95
96 static int desc_bound_bitpos (struct type *, int, int);
97
98 static int desc_bound_bitsize (struct type *, int, int);
99
100 static struct type *desc_index_type (struct type *, int);
101
102 static int desc_arity (struct type *);
103
104 static int ada_type_match (struct type *, struct type *, int);
105
106 static int ada_args_match (struct symbol *, struct value **, int);
107
108 static struct value *make_array_descriptor (struct type *, struct value *);
109
110 static void ada_add_block_symbols (struct obstack *,
111 const struct block *,
112 const lookup_name_info &lookup_name,
113 domain_enum, struct objfile *);
114
115 static void ada_add_all_symbols (struct obstack *, const struct block *,
116 const lookup_name_info &lookup_name,
117 domain_enum, int, int *);
118
119 static int is_nonfunction (struct block_symbol *, int);
120
121 static void add_defn_to_vec (struct obstack *, struct symbol *,
122 const struct block *);
123
124 static int num_defns_collected (struct obstack *);
125
126 static struct block_symbol *defns_collected (struct obstack *, int);
127
128 static struct value *resolve_subexp (expression_up *, int *, int,
129 struct type *, int,
130 innermost_block_tracker *);
131
132 static void replace_operator_with_call (expression_up *, int, int, int,
133 struct symbol *, const struct block *);
134
135 static int possible_user_operator_p (enum exp_opcode, struct value **);
136
137 static const char *ada_op_name (enum exp_opcode);
138
139 static const char *ada_decoded_op_name (enum exp_opcode);
140
141 static int numeric_type_p (struct type *);
142
143 static int integer_type_p (struct type *);
144
145 static int scalar_type_p (struct type *);
146
147 static int discrete_type_p (struct type *);
148
149 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
150 int, int);
151
152 static struct value *evaluate_subexp_type (struct expression *, int *);
153
154 static struct type *ada_find_parallel_type_with_name (struct type *,
155 const char *);
156
157 static int is_dynamic_field (struct type *, int);
158
159 static struct type *to_fixed_variant_branch_type (struct type *,
160 const gdb_byte *,
161 CORE_ADDR, struct value *);
162
163 static struct type *to_fixed_array_type (struct type *, struct value *, int);
164
165 static struct type *to_fixed_range_type (struct type *, struct value *);
166
167 static struct type *to_static_fixed_type (struct type *);
168 static struct type *static_unwrap_type (struct type *type);
169
170 static struct value *unwrap_value (struct value *);
171
172 static struct type *constrained_packed_array_type (struct type *, long *);
173
174 static struct type *decode_constrained_packed_array_type (struct type *);
175
176 static long decode_packed_array_bitsize (struct type *);
177
178 static struct value *decode_constrained_packed_array (struct value *);
179
180 static int ada_is_packed_array_type (struct type *);
181
182 static int ada_is_unconstrained_packed_array_type (struct type *);
183
184 static struct value *value_subscript_packed (struct value *, int,
185 struct value **);
186
187 static struct value *coerce_unspec_val_to_type (struct value *,
188 struct type *);
189
190 static int lesseq_defined_than (struct symbol *, struct symbol *);
191
192 static int equiv_types (struct type *, struct type *);
193
194 static int is_name_suffix (const char *);
195
196 static int advance_wild_match (const char **, const char *, int);
197
198 static bool wild_match (const char *name, const char *patn);
199
200 static struct value *ada_coerce_ref (struct value *);
201
202 static LONGEST pos_atr (struct value *);
203
204 static struct value *value_pos_atr (struct type *, struct value *);
205
206 static struct value *value_val_atr (struct type *, struct value *);
207
208 static struct symbol *standard_lookup (const char *, const struct block *,
209 domain_enum);
210
211 static struct value *ada_search_struct_field (const char *, struct value *, int,
212 struct type *);
213
214 static struct value *ada_value_primitive_field (struct value *, int, int,
215 struct type *);
216
217 static int find_struct_field (const char *, struct type *, int,
218 struct type **, int *, int *, int *, int *);
219
220 static int ada_resolve_function (struct block_symbol *, int,
221 struct value **, int, const char *,
222 struct type *, int);
223
224 static int ada_is_direct_array_type (struct type *);
225
226 static void ada_language_arch_info (struct gdbarch *,
227 struct language_arch_info *);
228
229 static struct value *ada_index_struct_field (int, struct value *, int,
230 struct type *);
231
232 static struct value *assign_aggregate (struct value *, struct value *,
233 struct expression *,
234 int *, enum noside);
235
236 static void aggregate_assign_from_choices (struct value *, struct value *,
237 struct expression *,
238 int *, LONGEST *, int *,
239 int, LONGEST, LONGEST);
240
241 static void aggregate_assign_positional (struct value *, struct value *,
242 struct expression *,
243 int *, LONGEST *, int *, int,
244 LONGEST, LONGEST);
245
246
247 static void aggregate_assign_others (struct value *, struct value *,
248 struct expression *,
249 int *, LONGEST *, int, LONGEST, LONGEST);
250
251
252 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
253
254
255 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
256 int *, enum noside);
257
258 static void ada_forward_operator_length (struct expression *, int, int *,
259 int *);
260
261 static struct type *ada_find_any_type (const char *name);
262
263 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
264 (const lookup_name_info &lookup_name);
265
266 \f
267
268 /* The result of a symbol lookup to be stored in our symbol cache. */
269
270 struct cache_entry
271 {
272 /* The name used to perform the lookup. */
273 const char *name;
274 /* The namespace used during the lookup. */
275 domain_enum domain;
276 /* The symbol returned by the lookup, or NULL if no matching symbol
277 was found. */
278 struct symbol *sym;
279 /* The block where the symbol was found, or NULL if no matching
280 symbol was found. */
281 const struct block *block;
282 /* A pointer to the next entry with the same hash. */
283 struct cache_entry *next;
284 };
285
286 /* The Ada symbol cache, used to store the result of Ada-mode symbol
287 lookups in the course of executing the user's commands.
288
289 The cache is implemented using a simple, fixed-sized hash.
290 The size is fixed on the grounds that there are not likely to be
291 all that many symbols looked up during any given session, regardless
292 of the size of the symbol table. If we decide to go to a resizable
293 table, let's just use the stuff from libiberty instead. */
294
295 #define HASH_SIZE 1009
296
297 struct ada_symbol_cache
298 {
299 /* An obstack used to store the entries in our cache. */
300 struct obstack cache_space;
301
302 /* The root of the hash table used to implement our symbol cache. */
303 struct cache_entry *root[HASH_SIZE];
304 };
305
306 static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
307
308 /* Maximum-sized dynamic type. */
309 static unsigned int varsize_limit;
310
311 static const char ada_completer_word_break_characters[] =
312 #ifdef VMS
313 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
314 #else
315 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
316 #endif
317
318 /* The name of the symbol to use to get the name of the main subprogram. */
319 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
320 = "__gnat_ada_main_program_name";
321
322 /* Limit on the number of warnings to raise per expression evaluation. */
323 static int warning_limit = 2;
324
325 /* Number of warning messages issued; reset to 0 by cleanups after
326 expression evaluation. */
327 static int warnings_issued = 0;
328
329 static const char *known_runtime_file_name_patterns[] = {
330 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
331 };
332
333 static const char *known_auxiliary_function_name_patterns[] = {
334 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
335 };
336
337 /* Maintenance-related settings for this module. */
338
339 static struct cmd_list_element *maint_set_ada_cmdlist;
340 static struct cmd_list_element *maint_show_ada_cmdlist;
341
342 /* Implement the "maintenance set ada" (prefix) command. */
343
344 static void
345 maint_set_ada_cmd (const char *args, int from_tty)
346 {
347 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
348 gdb_stdout);
349 }
350
351 /* Implement the "maintenance show ada" (prefix) command. */
352
353 static void
354 maint_show_ada_cmd (const char *args, int from_tty)
355 {
356 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
357 }
358
359 /* The "maintenance ada set/show ignore-descriptive-type" value. */
360
361 static int ada_ignore_descriptive_types_p = 0;
362
363 /* Inferior-specific data. */
364
365 /* Per-inferior data for this module. */
366
367 struct ada_inferior_data
368 {
369 /* The ada__tags__type_specific_data type, which is used when decoding
370 tagged types. With older versions of GNAT, this type was directly
371 accessible through a component ("tsd") in the object tag. But this
372 is no longer the case, so we cache it for each inferior. */
373 struct type *tsd_type = nullptr;
374
375 /* The exception_support_info data. This data is used to determine
376 how to implement support for Ada exception catchpoints in a given
377 inferior. */
378 const struct exception_support_info *exception_info = nullptr;
379 };
380
381 /* Our key to this module's inferior data. */
382 static const struct inferior_key<ada_inferior_data> ada_inferior_data;
383
384 /* Return our inferior data for the given inferior (INF).
385
386 This function always returns a valid pointer to an allocated
387 ada_inferior_data structure. If INF's inferior data has not
388 been previously set, this functions creates a new one with all
389 fields set to zero, sets INF's inferior to it, and then returns
390 a pointer to that newly allocated ada_inferior_data. */
391
392 static struct ada_inferior_data *
393 get_ada_inferior_data (struct inferior *inf)
394 {
395 struct ada_inferior_data *data;
396
397 data = ada_inferior_data.get (inf);
398 if (data == NULL)
399 data = ada_inferior_data.emplace (inf);
400
401 return data;
402 }
403
404 /* Perform all necessary cleanups regarding our module's inferior data
405 that is required after the inferior INF just exited. */
406
407 static void
408 ada_inferior_exit (struct inferior *inf)
409 {
410 ada_inferior_data.clear (inf);
411 }
412
413
414 /* program-space-specific data. */
415
416 /* This module's per-program-space data. */
417 struct ada_pspace_data
418 {
419 ~ada_pspace_data ()
420 {
421 if (sym_cache != NULL)
422 ada_free_symbol_cache (sym_cache);
423 }
424
425 /* The Ada symbol cache. */
426 struct ada_symbol_cache *sym_cache = nullptr;
427 };
428
429 /* Key to our per-program-space data. */
430 static const struct program_space_key<ada_pspace_data> ada_pspace_data_handle;
431
432 /* Return this module's data for the given program space (PSPACE).
433 If not is found, add a zero'ed one now.
434
435 This function always returns a valid object. */
436
437 static struct ada_pspace_data *
438 get_ada_pspace_data (struct program_space *pspace)
439 {
440 struct ada_pspace_data *data;
441
442 data = ada_pspace_data_handle.get (pspace);
443 if (data == NULL)
444 data = ada_pspace_data_handle.emplace (pspace);
445
446 return data;
447 }
448
449 /* Utilities */
450
451 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
452 all typedef layers have been peeled. Otherwise, return TYPE.
453
454 Normally, we really expect a typedef type to only have 1 typedef layer.
455 In other words, we really expect the target type of a typedef type to be
456 a non-typedef type. This is particularly true for Ada units, because
457 the language does not have a typedef vs not-typedef distinction.
458 In that respect, the Ada compiler has been trying to eliminate as many
459 typedef definitions in the debugging information, since they generally
460 do not bring any extra information (we still use typedef under certain
461 circumstances related mostly to the GNAT encoding).
462
463 Unfortunately, we have seen situations where the debugging information
464 generated by the compiler leads to such multiple typedef layers. For
465 instance, consider the following example with stabs:
466
467 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
468 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
469
470 This is an error in the debugging information which causes type
471 pck__float_array___XUP to be defined twice, and the second time,
472 it is defined as a typedef of a typedef.
473
474 This is on the fringe of legality as far as debugging information is
475 concerned, and certainly unexpected. But it is easy to handle these
476 situations correctly, so we can afford to be lenient in this case. */
477
478 static struct type *
479 ada_typedef_target_type (struct type *type)
480 {
481 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
482 type = TYPE_TARGET_TYPE (type);
483 return type;
484 }
485
486 /* Given DECODED_NAME a string holding a symbol name in its
487 decoded form (ie using the Ada dotted notation), returns
488 its unqualified name. */
489
490 static const char *
491 ada_unqualified_name (const char *decoded_name)
492 {
493 const char *result;
494
495 /* If the decoded name starts with '<', it means that the encoded
496 name does not follow standard naming conventions, and thus that
497 it is not your typical Ada symbol name. Trying to unqualify it
498 is therefore pointless and possibly erroneous. */
499 if (decoded_name[0] == '<')
500 return decoded_name;
501
502 result = strrchr (decoded_name, '.');
503 if (result != NULL)
504 result++; /* Skip the dot... */
505 else
506 result = decoded_name;
507
508 return result;
509 }
510
511 /* Return a string starting with '<', followed by STR, and '>'. */
512
513 static std::string
514 add_angle_brackets (const char *str)
515 {
516 return string_printf ("<%s>", str);
517 }
518
519 static const char *
520 ada_get_gdb_completer_word_break_characters (void)
521 {
522 return ada_completer_word_break_characters;
523 }
524
525 /* Print an array element index using the Ada syntax. */
526
527 static void
528 ada_print_array_index (struct value *index_value, struct ui_file *stream,
529 const struct value_print_options *options)
530 {
531 LA_VALUE_PRINT (index_value, stream, options);
532 fprintf_filtered (stream, " => ");
533 }
534
535 /* la_watch_location_expression for Ada. */
536
537 gdb::unique_xmalloc_ptr<char>
538 ada_watch_location_expression (struct type *type, CORE_ADDR addr)
539 {
540 type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
541 std::string name = type_to_string (type);
542 return gdb::unique_xmalloc_ptr<char>
543 (xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr)));
544 }
545
546 /* Assuming VECT points to an array of *SIZE objects of size
547 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
548 updating *SIZE as necessary and returning the (new) array. */
549
550 void *
551 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
552 {
553 if (*size < min_size)
554 {
555 *size *= 2;
556 if (*size < min_size)
557 *size = min_size;
558 vect = xrealloc (vect, *size * element_size);
559 }
560 return vect;
561 }
562
563 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
564 suffix of FIELD_NAME beginning "___". */
565
566 static int
567 field_name_match (const char *field_name, const char *target)
568 {
569 int len = strlen (target);
570
571 return
572 (strncmp (field_name, target, len) == 0
573 && (field_name[len] == '\0'
574 || (startswith (field_name + len, "___")
575 && strcmp (field_name + strlen (field_name) - 6,
576 "___XVN") != 0)));
577 }
578
579
580 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
581 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
582 and return its index. This function also handles fields whose name
583 have ___ suffixes because the compiler sometimes alters their name
584 by adding such a suffix to represent fields with certain constraints.
585 If the field could not be found, return a negative number if
586 MAYBE_MISSING is set. Otherwise raise an error. */
587
588 int
589 ada_get_field_index (const struct type *type, const char *field_name,
590 int maybe_missing)
591 {
592 int fieldno;
593 struct type *struct_type = check_typedef ((struct type *) type);
594
595 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
596 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
597 return fieldno;
598
599 if (!maybe_missing)
600 error (_("Unable to find field %s in struct %s. Aborting"),
601 field_name, TYPE_NAME (struct_type));
602
603 return -1;
604 }
605
606 /* The length of the prefix of NAME prior to any "___" suffix. */
607
608 int
609 ada_name_prefix_len (const char *name)
610 {
611 if (name == NULL)
612 return 0;
613 else
614 {
615 const char *p = strstr (name, "___");
616
617 if (p == NULL)
618 return strlen (name);
619 else
620 return p - name;
621 }
622 }
623
624 /* Return non-zero if SUFFIX is a suffix of STR.
625 Return zero if STR is null. */
626
627 static int
628 is_suffix (const char *str, const char *suffix)
629 {
630 int len1, len2;
631
632 if (str == NULL)
633 return 0;
634 len1 = strlen (str);
635 len2 = strlen (suffix);
636 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
637 }
638
639 /* The contents of value VAL, treated as a value of type TYPE. The
640 result is an lval in memory if VAL is. */
641
642 static struct value *
643 coerce_unspec_val_to_type (struct value *val, struct type *type)
644 {
645 type = ada_check_typedef (type);
646 if (value_type (val) == type)
647 return val;
648 else
649 {
650 struct value *result;
651
652 /* Make sure that the object size is not unreasonable before
653 trying to allocate some memory for it. */
654 ada_ensure_varsize_limit (type);
655
656 if (value_lazy (val)
657 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
658 result = allocate_value_lazy (type);
659 else
660 {
661 result = allocate_value (type);
662 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
663 }
664 set_value_component_location (result, val);
665 set_value_bitsize (result, value_bitsize (val));
666 set_value_bitpos (result, value_bitpos (val));
667 if (VALUE_LVAL (result) == lval_memory)
668 set_value_address (result, value_address (val));
669 return result;
670 }
671 }
672
673 static const gdb_byte *
674 cond_offset_host (const gdb_byte *valaddr, long offset)
675 {
676 if (valaddr == NULL)
677 return NULL;
678 else
679 return valaddr + offset;
680 }
681
682 static CORE_ADDR
683 cond_offset_target (CORE_ADDR address, long offset)
684 {
685 if (address == 0)
686 return 0;
687 else
688 return address + offset;
689 }
690
691 /* Issue a warning (as for the definition of warning in utils.c, but
692 with exactly one argument rather than ...), unless the limit on the
693 number of warnings has passed during the evaluation of the current
694 expression. */
695
696 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
697 provided by "complaint". */
698 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
699
700 static void
701 lim_warning (const char *format, ...)
702 {
703 va_list args;
704
705 va_start (args, format);
706 warnings_issued += 1;
707 if (warnings_issued <= warning_limit)
708 vwarning (format, args);
709
710 va_end (args);
711 }
712
713 /* Issue an error if the size of an object of type T is unreasonable,
714 i.e. if it would be a bad idea to allocate a value of this type in
715 GDB. */
716
717 void
718 ada_ensure_varsize_limit (const struct type *type)
719 {
720 if (TYPE_LENGTH (type) > varsize_limit)
721 error (_("object size is larger than varsize-limit"));
722 }
723
724 /* Maximum value of a SIZE-byte signed integer type. */
725 static LONGEST
726 max_of_size (int size)
727 {
728 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
729
730 return top_bit | (top_bit - 1);
731 }
732
733 /* Minimum value of a SIZE-byte signed integer type. */
734 static LONGEST
735 min_of_size (int size)
736 {
737 return -max_of_size (size) - 1;
738 }
739
740 /* Maximum value of a SIZE-byte unsigned integer type. */
741 static ULONGEST
742 umax_of_size (int size)
743 {
744 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
745
746 return top_bit | (top_bit - 1);
747 }
748
749 /* Maximum value of integral type T, as a signed quantity. */
750 static LONGEST
751 max_of_type (struct type *t)
752 {
753 if (TYPE_UNSIGNED (t))
754 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
755 else
756 return max_of_size (TYPE_LENGTH (t));
757 }
758
759 /* Minimum value of integral type T, as a signed quantity. */
760 static LONGEST
761 min_of_type (struct type *t)
762 {
763 if (TYPE_UNSIGNED (t))
764 return 0;
765 else
766 return min_of_size (TYPE_LENGTH (t));
767 }
768
769 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
770 LONGEST
771 ada_discrete_type_high_bound (struct type *type)
772 {
773 type = resolve_dynamic_type (type, NULL, 0);
774 switch (TYPE_CODE (type))
775 {
776 case TYPE_CODE_RANGE:
777 return TYPE_HIGH_BOUND (type);
778 case TYPE_CODE_ENUM:
779 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
780 case TYPE_CODE_BOOL:
781 return 1;
782 case TYPE_CODE_CHAR:
783 case TYPE_CODE_INT:
784 return max_of_type (type);
785 default:
786 error (_("Unexpected type in ada_discrete_type_high_bound."));
787 }
788 }
789
790 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
791 LONGEST
792 ada_discrete_type_low_bound (struct type *type)
793 {
794 type = resolve_dynamic_type (type, NULL, 0);
795 switch (TYPE_CODE (type))
796 {
797 case TYPE_CODE_RANGE:
798 return TYPE_LOW_BOUND (type);
799 case TYPE_CODE_ENUM:
800 return TYPE_FIELD_ENUMVAL (type, 0);
801 case TYPE_CODE_BOOL:
802 return 0;
803 case TYPE_CODE_CHAR:
804 case TYPE_CODE_INT:
805 return min_of_type (type);
806 default:
807 error (_("Unexpected type in ada_discrete_type_low_bound."));
808 }
809 }
810
811 /* The identity on non-range types. For range types, the underlying
812 non-range scalar type. */
813
814 static struct type *
815 get_base_type (struct type *type)
816 {
817 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
818 {
819 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
820 return type;
821 type = TYPE_TARGET_TYPE (type);
822 }
823 return type;
824 }
825
826 /* Return a decoded version of the given VALUE. This means returning
827 a value whose type is obtained by applying all the GNAT-specific
828 encondings, making the resulting type a static but standard description
829 of the initial type. */
830
831 struct value *
832 ada_get_decoded_value (struct value *value)
833 {
834 struct type *type = ada_check_typedef (value_type (value));
835
836 if (ada_is_array_descriptor_type (type)
837 || (ada_is_constrained_packed_array_type (type)
838 && TYPE_CODE (type) != TYPE_CODE_PTR))
839 {
840 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
841 value = ada_coerce_to_simple_array_ptr (value);
842 else
843 value = ada_coerce_to_simple_array (value);
844 }
845 else
846 value = ada_to_fixed_value (value);
847
848 return value;
849 }
850
851 /* Same as ada_get_decoded_value, but with the given TYPE.
852 Because there is no associated actual value for this type,
853 the resulting type might be a best-effort approximation in
854 the case of dynamic types. */
855
856 struct type *
857 ada_get_decoded_type (struct type *type)
858 {
859 type = to_static_fixed_type (type);
860 if (ada_is_constrained_packed_array_type (type))
861 type = ada_coerce_to_simple_array_type (type);
862 return type;
863 }
864
865 \f
866
867 /* Language Selection */
868
869 /* If the main program is in Ada, return language_ada, otherwise return LANG
870 (the main program is in Ada iif the adainit symbol is found). */
871
872 enum language
873 ada_update_initial_language (enum language lang)
874 {
875 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
876 (struct objfile *) NULL).minsym != NULL)
877 return language_ada;
878
879 return lang;
880 }
881
882 /* If the main procedure is written in Ada, then return its name.
883 The result is good until the next call. Return NULL if the main
884 procedure doesn't appear to be in Ada. */
885
886 char *
887 ada_main_name (void)
888 {
889 struct bound_minimal_symbol msym;
890 static gdb::unique_xmalloc_ptr<char> main_program_name;
891
892 /* For Ada, the name of the main procedure is stored in a specific
893 string constant, generated by the binder. Look for that symbol,
894 extract its address, and then read that string. If we didn't find
895 that string, then most probably the main procedure is not written
896 in Ada. */
897 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
898
899 if (msym.minsym != NULL)
900 {
901 CORE_ADDR main_program_name_addr;
902 int err_code;
903
904 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
905 if (main_program_name_addr == 0)
906 error (_("Invalid address for Ada main program name."));
907
908 target_read_string (main_program_name_addr, &main_program_name,
909 1024, &err_code);
910
911 if (err_code != 0)
912 return NULL;
913 return main_program_name.get ();
914 }
915
916 /* The main procedure doesn't seem to be in Ada. */
917 return NULL;
918 }
919 \f
920 /* Symbols */
921
922 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
923 of NULLs. */
924
925 const struct ada_opname_map ada_opname_table[] = {
926 {"Oadd", "\"+\"", BINOP_ADD},
927 {"Osubtract", "\"-\"", BINOP_SUB},
928 {"Omultiply", "\"*\"", BINOP_MUL},
929 {"Odivide", "\"/\"", BINOP_DIV},
930 {"Omod", "\"mod\"", BINOP_MOD},
931 {"Orem", "\"rem\"", BINOP_REM},
932 {"Oexpon", "\"**\"", BINOP_EXP},
933 {"Olt", "\"<\"", BINOP_LESS},
934 {"Ole", "\"<=\"", BINOP_LEQ},
935 {"Ogt", "\">\"", BINOP_GTR},
936 {"Oge", "\">=\"", BINOP_GEQ},
937 {"Oeq", "\"=\"", BINOP_EQUAL},
938 {"One", "\"/=\"", BINOP_NOTEQUAL},
939 {"Oand", "\"and\"", BINOP_BITWISE_AND},
940 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
941 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
942 {"Oconcat", "\"&\"", BINOP_CONCAT},
943 {"Oabs", "\"abs\"", UNOP_ABS},
944 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
945 {"Oadd", "\"+\"", UNOP_PLUS},
946 {"Osubtract", "\"-\"", UNOP_NEG},
947 {NULL, NULL}
948 };
949
950 /* The "encoded" form of DECODED, according to GNAT conventions. The
951 result is valid until the next call to ada_encode. If
952 THROW_ERRORS, throw an error if invalid operator name is found.
953 Otherwise, return NULL in that case. */
954
955 static char *
956 ada_encode_1 (const char *decoded, bool throw_errors)
957 {
958 static char *encoding_buffer = NULL;
959 static size_t encoding_buffer_size = 0;
960 const char *p;
961 int k;
962
963 if (decoded == NULL)
964 return NULL;
965
966 GROW_VECT (encoding_buffer, encoding_buffer_size,
967 2 * strlen (decoded) + 10);
968
969 k = 0;
970 for (p = decoded; *p != '\0'; p += 1)
971 {
972 if (*p == '.')
973 {
974 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
975 k += 2;
976 }
977 else if (*p == '"')
978 {
979 const struct ada_opname_map *mapping;
980
981 for (mapping = ada_opname_table;
982 mapping->encoded != NULL
983 && !startswith (p, mapping->decoded); mapping += 1)
984 ;
985 if (mapping->encoded == NULL)
986 {
987 if (throw_errors)
988 error (_("invalid Ada operator name: %s"), p);
989 else
990 return NULL;
991 }
992 strcpy (encoding_buffer + k, mapping->encoded);
993 k += strlen (mapping->encoded);
994 break;
995 }
996 else
997 {
998 encoding_buffer[k] = *p;
999 k += 1;
1000 }
1001 }
1002
1003 encoding_buffer[k] = '\0';
1004 return encoding_buffer;
1005 }
1006
1007 /* The "encoded" form of DECODED, according to GNAT conventions.
1008 The result is valid until the next call to ada_encode. */
1009
1010 char *
1011 ada_encode (const char *decoded)
1012 {
1013 return ada_encode_1 (decoded, true);
1014 }
1015
1016 /* Return NAME folded to lower case, or, if surrounded by single
1017 quotes, unfolded, but with the quotes stripped away. Result good
1018 to next call. */
1019
1020 char *
1021 ada_fold_name (const char *name)
1022 {
1023 static char *fold_buffer = NULL;
1024 static size_t fold_buffer_size = 0;
1025
1026 int len = strlen (name);
1027 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
1028
1029 if (name[0] == '\'')
1030 {
1031 strncpy (fold_buffer, name + 1, len - 2);
1032 fold_buffer[len - 2] = '\000';
1033 }
1034 else
1035 {
1036 int i;
1037
1038 for (i = 0; i <= len; i += 1)
1039 fold_buffer[i] = tolower (name[i]);
1040 }
1041
1042 return fold_buffer;
1043 }
1044
1045 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1046
1047 static int
1048 is_lower_alphanum (const char c)
1049 {
1050 return (isdigit (c) || (isalpha (c) && islower (c)));
1051 }
1052
1053 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1054 This function saves in LEN the length of that same symbol name but
1055 without either of these suffixes:
1056 . .{DIGIT}+
1057 . ${DIGIT}+
1058 . ___{DIGIT}+
1059 . __{DIGIT}+.
1060
1061 These are suffixes introduced by the compiler for entities such as
1062 nested subprogram for instance, in order to avoid name clashes.
1063 They do not serve any purpose for the debugger. */
1064
1065 static void
1066 ada_remove_trailing_digits (const char *encoded, int *len)
1067 {
1068 if (*len > 1 && isdigit (encoded[*len - 1]))
1069 {
1070 int i = *len - 2;
1071
1072 while (i > 0 && isdigit (encoded[i]))
1073 i--;
1074 if (i >= 0 && encoded[i] == '.')
1075 *len = i;
1076 else if (i >= 0 && encoded[i] == '$')
1077 *len = i;
1078 else if (i >= 2 && startswith (encoded + i - 2, "___"))
1079 *len = i - 2;
1080 else if (i >= 1 && startswith (encoded + i - 1, "__"))
1081 *len = i - 1;
1082 }
1083 }
1084
1085 /* Remove the suffix introduced by the compiler for protected object
1086 subprograms. */
1087
1088 static void
1089 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1090 {
1091 /* Remove trailing N. */
1092
1093 /* Protected entry subprograms are broken into two
1094 separate subprograms: The first one is unprotected, and has
1095 a 'N' suffix; the second is the protected version, and has
1096 the 'P' suffix. The second calls the first one after handling
1097 the protection. Since the P subprograms are internally generated,
1098 we leave these names undecoded, giving the user a clue that this
1099 entity is internal. */
1100
1101 if (*len > 1
1102 && encoded[*len - 1] == 'N'
1103 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1104 *len = *len - 1;
1105 }
1106
1107 /* If ENCODED follows the GNAT entity encoding conventions, then return
1108 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1109 replaced by ENCODED.
1110
1111 The resulting string is valid until the next call of ada_decode.
1112 If the string is unchanged by decoding, the original string pointer
1113 is returned. */
1114
1115 const char *
1116 ada_decode (const char *encoded)
1117 {
1118 int i, j;
1119 int len0;
1120 const char *p;
1121 char *decoded;
1122 int at_start_name;
1123 static char *decoding_buffer = NULL;
1124 static size_t decoding_buffer_size = 0;
1125
1126 /* With function descriptors on PPC64, the value of a symbol named
1127 ".FN", if it exists, is the entry point of the function "FN". */
1128 if (encoded[0] == '.')
1129 encoded += 1;
1130
1131 /* The name of the Ada main procedure starts with "_ada_".
1132 This prefix is not part of the decoded name, so skip this part
1133 if we see this prefix. */
1134 if (startswith (encoded, "_ada_"))
1135 encoded += 5;
1136
1137 /* If the name starts with '_', then it is not a properly encoded
1138 name, so do not attempt to decode it. Similarly, if the name
1139 starts with '<', the name should not be decoded. */
1140 if (encoded[0] == '_' || encoded[0] == '<')
1141 goto Suppress;
1142
1143 len0 = strlen (encoded);
1144
1145 ada_remove_trailing_digits (encoded, &len0);
1146 ada_remove_po_subprogram_suffix (encoded, &len0);
1147
1148 /* Remove the ___X.* suffix if present. Do not forget to verify that
1149 the suffix is located before the current "end" of ENCODED. We want
1150 to avoid re-matching parts of ENCODED that have previously been
1151 marked as discarded (by decrementing LEN0). */
1152 p = strstr (encoded, "___");
1153 if (p != NULL && p - encoded < len0 - 3)
1154 {
1155 if (p[3] == 'X')
1156 len0 = p - encoded;
1157 else
1158 goto Suppress;
1159 }
1160
1161 /* Remove any trailing TKB suffix. It tells us that this symbol
1162 is for the body of a task, but that information does not actually
1163 appear in the decoded name. */
1164
1165 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1166 len0 -= 3;
1167
1168 /* Remove any trailing TB suffix. The TB suffix is slightly different
1169 from the TKB suffix because it is used for non-anonymous task
1170 bodies. */
1171
1172 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1173 len0 -= 2;
1174
1175 /* Remove trailing "B" suffixes. */
1176 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1177
1178 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1179 len0 -= 1;
1180
1181 /* Make decoded big enough for possible expansion by operator name. */
1182
1183 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1184 decoded = decoding_buffer;
1185
1186 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1187
1188 if (len0 > 1 && isdigit (encoded[len0 - 1]))
1189 {
1190 i = len0 - 2;
1191 while ((i >= 0 && isdigit (encoded[i]))
1192 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1193 i -= 1;
1194 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1195 len0 = i - 1;
1196 else if (encoded[i] == '$')
1197 len0 = i;
1198 }
1199
1200 /* The first few characters that are not alphabetic are not part
1201 of any encoding we use, so we can copy them over verbatim. */
1202
1203 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1204 decoded[j] = encoded[i];
1205
1206 at_start_name = 1;
1207 while (i < len0)
1208 {
1209 /* Is this a symbol function? */
1210 if (at_start_name && encoded[i] == 'O')
1211 {
1212 int k;
1213
1214 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1215 {
1216 int op_len = strlen (ada_opname_table[k].encoded);
1217 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1218 op_len - 1) == 0)
1219 && !isalnum (encoded[i + op_len]))
1220 {
1221 strcpy (decoded + j, ada_opname_table[k].decoded);
1222 at_start_name = 0;
1223 i += op_len;
1224 j += strlen (ada_opname_table[k].decoded);
1225 break;
1226 }
1227 }
1228 if (ada_opname_table[k].encoded != NULL)
1229 continue;
1230 }
1231 at_start_name = 0;
1232
1233 /* Replace "TK__" with "__", which will eventually be translated
1234 into "." (just below). */
1235
1236 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1237 i += 2;
1238
1239 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1240 be translated into "." (just below). These are internal names
1241 generated for anonymous blocks inside which our symbol is nested. */
1242
1243 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1244 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1245 && isdigit (encoded [i+4]))
1246 {
1247 int k = i + 5;
1248
1249 while (k < len0 && isdigit (encoded[k]))
1250 k++; /* Skip any extra digit. */
1251
1252 /* Double-check that the "__B_{DIGITS}+" sequence we found
1253 is indeed followed by "__". */
1254 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1255 i = k;
1256 }
1257
1258 /* Remove _E{DIGITS}+[sb] */
1259
1260 /* Just as for protected object subprograms, there are 2 categories
1261 of subprograms created by the compiler for each entry. The first
1262 one implements the actual entry code, and has a suffix following
1263 the convention above; the second one implements the barrier and
1264 uses the same convention as above, except that the 'E' is replaced
1265 by a 'B'.
1266
1267 Just as above, we do not decode the name of barrier functions
1268 to give the user a clue that the code he is debugging has been
1269 internally generated. */
1270
1271 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1272 && isdigit (encoded[i+2]))
1273 {
1274 int k = i + 3;
1275
1276 while (k < len0 && isdigit (encoded[k]))
1277 k++;
1278
1279 if (k < len0
1280 && (encoded[k] == 'b' || encoded[k] == 's'))
1281 {
1282 k++;
1283 /* Just as an extra precaution, make sure that if this
1284 suffix is followed by anything else, it is a '_'.
1285 Otherwise, we matched this sequence by accident. */
1286 if (k == len0
1287 || (k < len0 && encoded[k] == '_'))
1288 i = k;
1289 }
1290 }
1291
1292 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1293 the GNAT front-end in protected object subprograms. */
1294
1295 if (i < len0 + 3
1296 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1297 {
1298 /* Backtrack a bit up until we reach either the begining of
1299 the encoded name, or "__". Make sure that we only find
1300 digits or lowercase characters. */
1301 const char *ptr = encoded + i - 1;
1302
1303 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1304 ptr--;
1305 if (ptr < encoded
1306 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1307 i++;
1308 }
1309
1310 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1311 {
1312 /* This is a X[bn]* sequence not separated from the previous
1313 part of the name with a non-alpha-numeric character (in other
1314 words, immediately following an alpha-numeric character), then
1315 verify that it is placed at the end of the encoded name. If
1316 not, then the encoding is not valid and we should abort the
1317 decoding. Otherwise, just skip it, it is used in body-nested
1318 package names. */
1319 do
1320 i += 1;
1321 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1322 if (i < len0)
1323 goto Suppress;
1324 }
1325 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1326 {
1327 /* Replace '__' by '.'. */
1328 decoded[j] = '.';
1329 at_start_name = 1;
1330 i += 2;
1331 j += 1;
1332 }
1333 else
1334 {
1335 /* It's a character part of the decoded name, so just copy it
1336 over. */
1337 decoded[j] = encoded[i];
1338 i += 1;
1339 j += 1;
1340 }
1341 }
1342 decoded[j] = '\000';
1343
1344 /* Decoded names should never contain any uppercase character.
1345 Double-check this, and abort the decoding if we find one. */
1346
1347 for (i = 0; decoded[i] != '\0'; i += 1)
1348 if (isupper (decoded[i]) || decoded[i] == ' ')
1349 goto Suppress;
1350
1351 if (strcmp (decoded, encoded) == 0)
1352 return encoded;
1353 else
1354 return decoded;
1355
1356 Suppress:
1357 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1358 decoded = decoding_buffer;
1359 if (encoded[0] == '<')
1360 strcpy (decoded, encoded);
1361 else
1362 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
1363 return decoded;
1364
1365 }
1366
1367 /* Table for keeping permanent unique copies of decoded names. Once
1368 allocated, names in this table are never released. While this is a
1369 storage leak, it should not be significant unless there are massive
1370 changes in the set of decoded names in successive versions of a
1371 symbol table loaded during a single session. */
1372 static struct htab *decoded_names_store;
1373
1374 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1375 in the language-specific part of GSYMBOL, if it has not been
1376 previously computed. Tries to save the decoded name in the same
1377 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1378 in any case, the decoded symbol has a lifetime at least that of
1379 GSYMBOL).
1380 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1381 const, but nevertheless modified to a semantically equivalent form
1382 when a decoded name is cached in it. */
1383
1384 const char *
1385 ada_decode_symbol (const struct general_symbol_info *arg)
1386 {
1387 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1388 const char **resultp =
1389 &gsymbol->language_specific.demangled_name;
1390
1391 if (!gsymbol->ada_mangled)
1392 {
1393 const char *decoded = ada_decode (gsymbol->name);
1394 struct obstack *obstack = gsymbol->language_specific.obstack;
1395
1396 gsymbol->ada_mangled = 1;
1397
1398 if (obstack != NULL)
1399 *resultp
1400 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
1401 else
1402 {
1403 /* Sometimes, we can't find a corresponding objfile, in
1404 which case, we put the result on the heap. Since we only
1405 decode when needed, we hope this usually does not cause a
1406 significant memory leak (FIXME). */
1407
1408 char **slot = (char **) htab_find_slot (decoded_names_store,
1409 decoded, INSERT);
1410
1411 if (*slot == NULL)
1412 *slot = xstrdup (decoded);
1413 *resultp = *slot;
1414 }
1415 }
1416
1417 return *resultp;
1418 }
1419
1420 static char *
1421 ada_la_decode (const char *encoded, int options)
1422 {
1423 return xstrdup (ada_decode (encoded));
1424 }
1425
1426 /* Implement la_sniff_from_mangled_name for Ada. */
1427
1428 static int
1429 ada_sniff_from_mangled_name (const char *mangled, char **out)
1430 {
1431 const char *demangled = ada_decode (mangled);
1432
1433 *out = NULL;
1434
1435 if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1436 {
1437 /* Set the gsymbol language to Ada, but still return 0.
1438 Two reasons for that:
1439
1440 1. For Ada, we prefer computing the symbol's decoded name
1441 on the fly rather than pre-compute it, in order to save
1442 memory (Ada projects are typically very large).
1443
1444 2. There are some areas in the definition of the GNAT
1445 encoding where, with a bit of bad luck, we might be able
1446 to decode a non-Ada symbol, generating an incorrect
1447 demangled name (Eg: names ending with "TB" for instance
1448 are identified as task bodies and so stripped from
1449 the decoded name returned).
1450
1451 Returning 1, here, but not setting *DEMANGLED, helps us get a
1452 little bit of the best of both worlds. Because we're last,
1453 we should not affect any of the other languages that were
1454 able to demangle the symbol before us; we get to correctly
1455 tag Ada symbols as such; and even if we incorrectly tagged a
1456 non-Ada symbol, which should be rare, any routing through the
1457 Ada language should be transparent (Ada tries to behave much
1458 like C/C++ with non-Ada symbols). */
1459 return 1;
1460 }
1461
1462 return 0;
1463 }
1464
1465 \f
1466
1467 /* Arrays */
1468
1469 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1470 generated by the GNAT compiler to describe the index type used
1471 for each dimension of an array, check whether it follows the latest
1472 known encoding. If not, fix it up to conform to the latest encoding.
1473 Otherwise, do nothing. This function also does nothing if
1474 INDEX_DESC_TYPE is NULL.
1475
1476 The GNAT encoding used to describle the array index type evolved a bit.
1477 Initially, the information would be provided through the name of each
1478 field of the structure type only, while the type of these fields was
1479 described as unspecified and irrelevant. The debugger was then expected
1480 to perform a global type lookup using the name of that field in order
1481 to get access to the full index type description. Because these global
1482 lookups can be very expensive, the encoding was later enhanced to make
1483 the global lookup unnecessary by defining the field type as being
1484 the full index type description.
1485
1486 The purpose of this routine is to allow us to support older versions
1487 of the compiler by detecting the use of the older encoding, and by
1488 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1489 we essentially replace each field's meaningless type by the associated
1490 index subtype). */
1491
1492 void
1493 ada_fixup_array_indexes_type (struct type *index_desc_type)
1494 {
1495 int i;
1496
1497 if (index_desc_type == NULL)
1498 return;
1499 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1500
1501 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1502 to check one field only, no need to check them all). If not, return
1503 now.
1504
1505 If our INDEX_DESC_TYPE was generated using the older encoding,
1506 the field type should be a meaningless integer type whose name
1507 is not equal to the field name. */
1508 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1509 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1510 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1511 return;
1512
1513 /* Fixup each field of INDEX_DESC_TYPE. */
1514 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1515 {
1516 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
1517 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1518
1519 if (raw_type)
1520 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1521 }
1522 }
1523
1524 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1525
1526 static const char *bound_name[] = {
1527 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1528 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1529 };
1530
1531 /* Maximum number of array dimensions we are prepared to handle. */
1532
1533 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1534
1535
1536 /* The desc_* routines return primitive portions of array descriptors
1537 (fat pointers). */
1538
1539 /* The descriptor or array type, if any, indicated by TYPE; removes
1540 level of indirection, if needed. */
1541
1542 static struct type *
1543 desc_base_type (struct type *type)
1544 {
1545 if (type == NULL)
1546 return NULL;
1547 type = ada_check_typedef (type);
1548 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1549 type = ada_typedef_target_type (type);
1550
1551 if (type != NULL
1552 && (TYPE_CODE (type) == TYPE_CODE_PTR
1553 || TYPE_CODE (type) == TYPE_CODE_REF))
1554 return ada_check_typedef (TYPE_TARGET_TYPE (type));
1555 else
1556 return type;
1557 }
1558
1559 /* True iff TYPE indicates a "thin" array pointer type. */
1560
1561 static int
1562 is_thin_pntr (struct type *type)
1563 {
1564 return
1565 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1566 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1567 }
1568
1569 /* The descriptor type for thin pointer type TYPE. */
1570
1571 static struct type *
1572 thin_descriptor_type (struct type *type)
1573 {
1574 struct type *base_type = desc_base_type (type);
1575
1576 if (base_type == NULL)
1577 return NULL;
1578 if (is_suffix (ada_type_name (base_type), "___XVE"))
1579 return base_type;
1580 else
1581 {
1582 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1583
1584 if (alt_type == NULL)
1585 return base_type;
1586 else
1587 return alt_type;
1588 }
1589 }
1590
1591 /* A pointer to the array data for thin-pointer value VAL. */
1592
1593 static struct value *
1594 thin_data_pntr (struct value *val)
1595 {
1596 struct type *type = ada_check_typedef (value_type (val));
1597 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1598
1599 data_type = lookup_pointer_type (data_type);
1600
1601 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1602 return value_cast (data_type, value_copy (val));
1603 else
1604 return value_from_longest (data_type, value_address (val));
1605 }
1606
1607 /* True iff TYPE indicates a "thick" array pointer type. */
1608
1609 static int
1610 is_thick_pntr (struct type *type)
1611 {
1612 type = desc_base_type (type);
1613 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1614 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1615 }
1616
1617 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1618 pointer to one, the type of its bounds data; otherwise, NULL. */
1619
1620 static struct type *
1621 desc_bounds_type (struct type *type)
1622 {
1623 struct type *r;
1624
1625 type = desc_base_type (type);
1626
1627 if (type == NULL)
1628 return NULL;
1629 else if (is_thin_pntr (type))
1630 {
1631 type = thin_descriptor_type (type);
1632 if (type == NULL)
1633 return NULL;
1634 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1635 if (r != NULL)
1636 return ada_check_typedef (r);
1637 }
1638 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1639 {
1640 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1641 if (r != NULL)
1642 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1643 }
1644 return NULL;
1645 }
1646
1647 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1648 one, a pointer to its bounds data. Otherwise NULL. */
1649
1650 static struct value *
1651 desc_bounds (struct value *arr)
1652 {
1653 struct type *type = ada_check_typedef (value_type (arr));
1654
1655 if (is_thin_pntr (type))
1656 {
1657 struct type *bounds_type =
1658 desc_bounds_type (thin_descriptor_type (type));
1659 LONGEST addr;
1660
1661 if (bounds_type == NULL)
1662 error (_("Bad GNAT array descriptor"));
1663
1664 /* NOTE: The following calculation is not really kosher, but
1665 since desc_type is an XVE-encoded type (and shouldn't be),
1666 the correct calculation is a real pain. FIXME (and fix GCC). */
1667 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1668 addr = value_as_long (arr);
1669 else
1670 addr = value_address (arr);
1671
1672 return
1673 value_from_longest (lookup_pointer_type (bounds_type),
1674 addr - TYPE_LENGTH (bounds_type));
1675 }
1676
1677 else if (is_thick_pntr (type))
1678 {
1679 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1680 _("Bad GNAT array descriptor"));
1681 struct type *p_bounds_type = value_type (p_bounds);
1682
1683 if (p_bounds_type
1684 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1685 {
1686 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1687
1688 if (TYPE_STUB (target_type))
1689 p_bounds = value_cast (lookup_pointer_type
1690 (ada_check_typedef (target_type)),
1691 p_bounds);
1692 }
1693 else
1694 error (_("Bad GNAT array descriptor"));
1695
1696 return p_bounds;
1697 }
1698 else
1699 return NULL;
1700 }
1701
1702 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1703 position of the field containing the address of the bounds data. */
1704
1705 static int
1706 fat_pntr_bounds_bitpos (struct type *type)
1707 {
1708 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1709 }
1710
1711 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1712 size of the field containing the address of the bounds data. */
1713
1714 static int
1715 fat_pntr_bounds_bitsize (struct type *type)
1716 {
1717 type = desc_base_type (type);
1718
1719 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1720 return TYPE_FIELD_BITSIZE (type, 1);
1721 else
1722 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1723 }
1724
1725 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1726 pointer to one, the type of its array data (a array-with-no-bounds type);
1727 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1728 data. */
1729
1730 static struct type *
1731 desc_data_target_type (struct type *type)
1732 {
1733 type = desc_base_type (type);
1734
1735 /* NOTE: The following is bogus; see comment in desc_bounds. */
1736 if (is_thin_pntr (type))
1737 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
1738 else if (is_thick_pntr (type))
1739 {
1740 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1741
1742 if (data_type
1743 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
1744 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1745 }
1746
1747 return NULL;
1748 }
1749
1750 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1751 its array data. */
1752
1753 static struct value *
1754 desc_data (struct value *arr)
1755 {
1756 struct type *type = value_type (arr);
1757
1758 if (is_thin_pntr (type))
1759 return thin_data_pntr (arr);
1760 else if (is_thick_pntr (type))
1761 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1762 _("Bad GNAT array descriptor"));
1763 else
1764 return NULL;
1765 }
1766
1767
1768 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1769 position of the field containing the address of the data. */
1770
1771 static int
1772 fat_pntr_data_bitpos (struct type *type)
1773 {
1774 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1775 }
1776
1777 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1778 size of the field containing the address of the data. */
1779
1780 static int
1781 fat_pntr_data_bitsize (struct type *type)
1782 {
1783 type = desc_base_type (type);
1784
1785 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1786 return TYPE_FIELD_BITSIZE (type, 0);
1787 else
1788 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1789 }
1790
1791 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1792 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1793 bound, if WHICH is 1. The first bound is I=1. */
1794
1795 static struct value *
1796 desc_one_bound (struct value *bounds, int i, int which)
1797 {
1798 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1799 _("Bad GNAT array descriptor bounds"));
1800 }
1801
1802 /* If BOUNDS is an array-bounds structure type, return the bit position
1803 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1804 bound, if WHICH is 1. The first bound is I=1. */
1805
1806 static int
1807 desc_bound_bitpos (struct type *type, int i, int which)
1808 {
1809 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1810 }
1811
1812 /* If BOUNDS is an array-bounds structure type, return the bit field size
1813 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1814 bound, if WHICH is 1. The first bound is I=1. */
1815
1816 static int
1817 desc_bound_bitsize (struct type *type, int i, int which)
1818 {
1819 type = desc_base_type (type);
1820
1821 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1822 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1823 else
1824 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1825 }
1826
1827 /* If TYPE is the type of an array-bounds structure, the type of its
1828 Ith bound (numbering from 1). Otherwise, NULL. */
1829
1830 static struct type *
1831 desc_index_type (struct type *type, int i)
1832 {
1833 type = desc_base_type (type);
1834
1835 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1836 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1837 else
1838 return NULL;
1839 }
1840
1841 /* The number of index positions in the array-bounds type TYPE.
1842 Return 0 if TYPE is NULL. */
1843
1844 static int
1845 desc_arity (struct type *type)
1846 {
1847 type = desc_base_type (type);
1848
1849 if (type != NULL)
1850 return TYPE_NFIELDS (type) / 2;
1851 return 0;
1852 }
1853
1854 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1855 an array descriptor type (representing an unconstrained array
1856 type). */
1857
1858 static int
1859 ada_is_direct_array_type (struct type *type)
1860 {
1861 if (type == NULL)
1862 return 0;
1863 type = ada_check_typedef (type);
1864 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1865 || ada_is_array_descriptor_type (type));
1866 }
1867
1868 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1869 * to one. */
1870
1871 static int
1872 ada_is_array_type (struct type *type)
1873 {
1874 while (type != NULL
1875 && (TYPE_CODE (type) == TYPE_CODE_PTR
1876 || TYPE_CODE (type) == TYPE_CODE_REF))
1877 type = TYPE_TARGET_TYPE (type);
1878 return ada_is_direct_array_type (type);
1879 }
1880
1881 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1882
1883 int
1884 ada_is_simple_array_type (struct type *type)
1885 {
1886 if (type == NULL)
1887 return 0;
1888 type = ada_check_typedef (type);
1889 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1890 || (TYPE_CODE (type) == TYPE_CODE_PTR
1891 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1892 == TYPE_CODE_ARRAY));
1893 }
1894
1895 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1896
1897 int
1898 ada_is_array_descriptor_type (struct type *type)
1899 {
1900 struct type *data_type = desc_data_target_type (type);
1901
1902 if (type == NULL)
1903 return 0;
1904 type = ada_check_typedef (type);
1905 return (data_type != NULL
1906 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1907 && desc_arity (desc_bounds_type (type)) > 0);
1908 }
1909
1910 /* Non-zero iff type is a partially mal-formed GNAT array
1911 descriptor. FIXME: This is to compensate for some problems with
1912 debugging output from GNAT. Re-examine periodically to see if it
1913 is still needed. */
1914
1915 int
1916 ada_is_bogus_array_descriptor (struct type *type)
1917 {
1918 return
1919 type != NULL
1920 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1921 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1922 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1923 && !ada_is_array_descriptor_type (type);
1924 }
1925
1926
1927 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1928 (fat pointer) returns the type of the array data described---specifically,
1929 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1930 in from the descriptor; otherwise, they are left unspecified. If
1931 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1932 returns NULL. The result is simply the type of ARR if ARR is not
1933 a descriptor. */
1934 struct type *
1935 ada_type_of_array (struct value *arr, int bounds)
1936 {
1937 if (ada_is_constrained_packed_array_type (value_type (arr)))
1938 return decode_constrained_packed_array_type (value_type (arr));
1939
1940 if (!ada_is_array_descriptor_type (value_type (arr)))
1941 return value_type (arr);
1942
1943 if (!bounds)
1944 {
1945 struct type *array_type =
1946 ada_check_typedef (desc_data_target_type (value_type (arr)));
1947
1948 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1949 TYPE_FIELD_BITSIZE (array_type, 0) =
1950 decode_packed_array_bitsize (value_type (arr));
1951
1952 return array_type;
1953 }
1954 else
1955 {
1956 struct type *elt_type;
1957 int arity;
1958 struct value *descriptor;
1959
1960 elt_type = ada_array_element_type (value_type (arr), -1);
1961 arity = ada_array_arity (value_type (arr));
1962
1963 if (elt_type == NULL || arity == 0)
1964 return ada_check_typedef (value_type (arr));
1965
1966 descriptor = desc_bounds (arr);
1967 if (value_as_long (descriptor) == 0)
1968 return NULL;
1969 while (arity > 0)
1970 {
1971 struct type *range_type = alloc_type_copy (value_type (arr));
1972 struct type *array_type = alloc_type_copy (value_type (arr));
1973 struct value *low = desc_one_bound (descriptor, arity, 0);
1974 struct value *high = desc_one_bound (descriptor, arity, 1);
1975
1976 arity -= 1;
1977 create_static_range_type (range_type, value_type (low),
1978 longest_to_int (value_as_long (low)),
1979 longest_to_int (value_as_long (high)));
1980 elt_type = create_array_type (array_type, elt_type, range_type);
1981
1982 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1983 {
1984 /* We need to store the element packed bitsize, as well as
1985 recompute the array size, because it was previously
1986 computed based on the unpacked element size. */
1987 LONGEST lo = value_as_long (low);
1988 LONGEST hi = value_as_long (high);
1989
1990 TYPE_FIELD_BITSIZE (elt_type, 0) =
1991 decode_packed_array_bitsize (value_type (arr));
1992 /* If the array has no element, then the size is already
1993 zero, and does not need to be recomputed. */
1994 if (lo < hi)
1995 {
1996 int array_bitsize =
1997 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1998
1999 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2000 }
2001 }
2002 }
2003
2004 return lookup_pointer_type (elt_type);
2005 }
2006 }
2007
2008 /* If ARR does not represent an array, returns ARR unchanged.
2009 Otherwise, returns either a standard GDB array with bounds set
2010 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2011 GDB array. Returns NULL if ARR is a null fat pointer. */
2012
2013 struct value *
2014 ada_coerce_to_simple_array_ptr (struct value *arr)
2015 {
2016 if (ada_is_array_descriptor_type (value_type (arr)))
2017 {
2018 struct type *arrType = ada_type_of_array (arr, 1);
2019
2020 if (arrType == NULL)
2021 return NULL;
2022 return value_cast (arrType, value_copy (desc_data (arr)));
2023 }
2024 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2025 return decode_constrained_packed_array (arr);
2026 else
2027 return arr;
2028 }
2029
2030 /* If ARR does not represent an array, returns ARR unchanged.
2031 Otherwise, returns a standard GDB array describing ARR (which may
2032 be ARR itself if it already is in the proper form). */
2033
2034 struct value *
2035 ada_coerce_to_simple_array (struct value *arr)
2036 {
2037 if (ada_is_array_descriptor_type (value_type (arr)))
2038 {
2039 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2040
2041 if (arrVal == NULL)
2042 error (_("Bounds unavailable for null array pointer."));
2043 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
2044 return value_ind (arrVal);
2045 }
2046 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2047 return decode_constrained_packed_array (arr);
2048 else
2049 return arr;
2050 }
2051
2052 /* If TYPE represents a GNAT array type, return it translated to an
2053 ordinary GDB array type (possibly with BITSIZE fields indicating
2054 packing). For other types, is the identity. */
2055
2056 struct type *
2057 ada_coerce_to_simple_array_type (struct type *type)
2058 {
2059 if (ada_is_constrained_packed_array_type (type))
2060 return decode_constrained_packed_array_type (type);
2061
2062 if (ada_is_array_descriptor_type (type))
2063 return ada_check_typedef (desc_data_target_type (type));
2064
2065 return type;
2066 }
2067
2068 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2069
2070 static int
2071 ada_is_packed_array_type (struct type *type)
2072 {
2073 if (type == NULL)
2074 return 0;
2075 type = desc_base_type (type);
2076 type = ada_check_typedef (type);
2077 return
2078 ada_type_name (type) != NULL
2079 && strstr (ada_type_name (type), "___XP") != NULL;
2080 }
2081
2082 /* Non-zero iff TYPE represents a standard GNAT constrained
2083 packed-array type. */
2084
2085 int
2086 ada_is_constrained_packed_array_type (struct type *type)
2087 {
2088 return ada_is_packed_array_type (type)
2089 && !ada_is_array_descriptor_type (type);
2090 }
2091
2092 /* Non-zero iff TYPE represents an array descriptor for a
2093 unconstrained packed-array type. */
2094
2095 static int
2096 ada_is_unconstrained_packed_array_type (struct type *type)
2097 {
2098 return ada_is_packed_array_type (type)
2099 && ada_is_array_descriptor_type (type);
2100 }
2101
2102 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2103 return the size of its elements in bits. */
2104
2105 static long
2106 decode_packed_array_bitsize (struct type *type)
2107 {
2108 const char *raw_name;
2109 const char *tail;
2110 long bits;
2111
2112 /* Access to arrays implemented as fat pointers are encoded as a typedef
2113 of the fat pointer type. We need the name of the fat pointer type
2114 to do the decoding, so strip the typedef layer. */
2115 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2116 type = ada_typedef_target_type (type);
2117
2118 raw_name = ada_type_name (ada_check_typedef (type));
2119 if (!raw_name)
2120 raw_name = ada_type_name (desc_base_type (type));
2121
2122 if (!raw_name)
2123 return 0;
2124
2125 tail = strstr (raw_name, "___XP");
2126 gdb_assert (tail != NULL);
2127
2128 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2129 {
2130 lim_warning
2131 (_("could not understand bit size information on packed array"));
2132 return 0;
2133 }
2134
2135 return bits;
2136 }
2137
2138 /* Given that TYPE is a standard GDB array type with all bounds filled
2139 in, and that the element size of its ultimate scalar constituents
2140 (that is, either its elements, or, if it is an array of arrays, its
2141 elements' elements, etc.) is *ELT_BITS, return an identical type,
2142 but with the bit sizes of its elements (and those of any
2143 constituent arrays) recorded in the BITSIZE components of its
2144 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2145 in bits.
2146
2147 Note that, for arrays whose index type has an XA encoding where
2148 a bound references a record discriminant, getting that discriminant,
2149 and therefore the actual value of that bound, is not possible
2150 because none of the given parameters gives us access to the record.
2151 This function assumes that it is OK in the context where it is being
2152 used to return an array whose bounds are still dynamic and where
2153 the length is arbitrary. */
2154
2155 static struct type *
2156 constrained_packed_array_type (struct type *type, long *elt_bits)
2157 {
2158 struct type *new_elt_type;
2159 struct type *new_type;
2160 struct type *index_type_desc;
2161 struct type *index_type;
2162 LONGEST low_bound, high_bound;
2163
2164 type = ada_check_typedef (type);
2165 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2166 return type;
2167
2168 index_type_desc = ada_find_parallel_type (type, "___XA");
2169 if (index_type_desc)
2170 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2171 NULL);
2172 else
2173 index_type = TYPE_INDEX_TYPE (type);
2174
2175 new_type = alloc_type_copy (type);
2176 new_elt_type =
2177 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2178 elt_bits);
2179 create_array_type (new_type, new_elt_type, index_type);
2180 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2181 TYPE_NAME (new_type) = ada_type_name (type);
2182
2183 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2184 && is_dynamic_type (check_typedef (index_type)))
2185 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
2186 low_bound = high_bound = 0;
2187 if (high_bound < low_bound)
2188 *elt_bits = TYPE_LENGTH (new_type) = 0;
2189 else
2190 {
2191 *elt_bits *= (high_bound - low_bound + 1);
2192 TYPE_LENGTH (new_type) =
2193 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2194 }
2195
2196 TYPE_FIXED_INSTANCE (new_type) = 1;
2197 return new_type;
2198 }
2199
2200 /* The array type encoded by TYPE, where
2201 ada_is_constrained_packed_array_type (TYPE). */
2202
2203 static struct type *
2204 decode_constrained_packed_array_type (struct type *type)
2205 {
2206 const char *raw_name = ada_type_name (ada_check_typedef (type));
2207 char *name;
2208 const char *tail;
2209 struct type *shadow_type;
2210 long bits;
2211
2212 if (!raw_name)
2213 raw_name = ada_type_name (desc_base_type (type));
2214
2215 if (!raw_name)
2216 return NULL;
2217
2218 name = (char *) alloca (strlen (raw_name) + 1);
2219 tail = strstr (raw_name, "___XP");
2220 type = desc_base_type (type);
2221
2222 memcpy (name, raw_name, tail - raw_name);
2223 name[tail - raw_name] = '\000';
2224
2225 shadow_type = ada_find_parallel_type_with_name (type, name);
2226
2227 if (shadow_type == NULL)
2228 {
2229 lim_warning (_("could not find bounds information on packed array"));
2230 return NULL;
2231 }
2232 shadow_type = check_typedef (shadow_type);
2233
2234 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2235 {
2236 lim_warning (_("could not understand bounds "
2237 "information on packed array"));
2238 return NULL;
2239 }
2240
2241 bits = decode_packed_array_bitsize (type);
2242 return constrained_packed_array_type (shadow_type, &bits);
2243 }
2244
2245 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2246 array, returns a simple array that denotes that array. Its type is a
2247 standard GDB array type except that the BITSIZEs of the array
2248 target types are set to the number of bits in each element, and the
2249 type length is set appropriately. */
2250
2251 static struct value *
2252 decode_constrained_packed_array (struct value *arr)
2253 {
2254 struct type *type;
2255
2256 /* If our value is a pointer, then dereference it. Likewise if
2257 the value is a reference. Make sure that this operation does not
2258 cause the target type to be fixed, as this would indirectly cause
2259 this array to be decoded. The rest of the routine assumes that
2260 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2261 and "value_ind" routines to perform the dereferencing, as opposed
2262 to using "ada_coerce_ref" or "ada_value_ind". */
2263 arr = coerce_ref (arr);
2264 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
2265 arr = value_ind (arr);
2266
2267 type = decode_constrained_packed_array_type (value_type (arr));
2268 if (type == NULL)
2269 {
2270 error (_("can't unpack array"));
2271 return NULL;
2272 }
2273
2274 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
2275 && ada_is_modular_type (value_type (arr)))
2276 {
2277 /* This is a (right-justified) modular type representing a packed
2278 array with no wrapper. In order to interpret the value through
2279 the (left-justified) packed array type we just built, we must
2280 first left-justify it. */
2281 int bit_size, bit_pos;
2282 ULONGEST mod;
2283
2284 mod = ada_modulus (value_type (arr)) - 1;
2285 bit_size = 0;
2286 while (mod > 0)
2287 {
2288 bit_size += 1;
2289 mod >>= 1;
2290 }
2291 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2292 arr = ada_value_primitive_packed_val (arr, NULL,
2293 bit_pos / HOST_CHAR_BIT,
2294 bit_pos % HOST_CHAR_BIT,
2295 bit_size,
2296 type);
2297 }
2298
2299 return coerce_unspec_val_to_type (arr, type);
2300 }
2301
2302
2303 /* The value of the element of packed array ARR at the ARITY indices
2304 given in IND. ARR must be a simple array. */
2305
2306 static struct value *
2307 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2308 {
2309 int i;
2310 int bits, elt_off, bit_off;
2311 long elt_total_bit_offset;
2312 struct type *elt_type;
2313 struct value *v;
2314
2315 bits = 0;
2316 elt_total_bit_offset = 0;
2317 elt_type = ada_check_typedef (value_type (arr));
2318 for (i = 0; i < arity; i += 1)
2319 {
2320 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
2321 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2322 error
2323 (_("attempt to do packed indexing of "
2324 "something other than a packed array"));
2325 else
2326 {
2327 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2328 LONGEST lowerbound, upperbound;
2329 LONGEST idx;
2330
2331 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2332 {
2333 lim_warning (_("don't know bounds of array"));
2334 lowerbound = upperbound = 0;
2335 }
2336
2337 idx = pos_atr (ind[i]);
2338 if (idx < lowerbound || idx > upperbound)
2339 lim_warning (_("packed array index %ld out of bounds"),
2340 (long) idx);
2341 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2342 elt_total_bit_offset += (idx - lowerbound) * bits;
2343 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2344 }
2345 }
2346 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2347 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2348
2349 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2350 bits, elt_type);
2351 return v;
2352 }
2353
2354 /* Non-zero iff TYPE includes negative integer values. */
2355
2356 static int
2357 has_negatives (struct type *type)
2358 {
2359 switch (TYPE_CODE (type))
2360 {
2361 default:
2362 return 0;
2363 case TYPE_CODE_INT:
2364 return !TYPE_UNSIGNED (type);
2365 case TYPE_CODE_RANGE:
2366 return TYPE_LOW_BOUND (type) < 0;
2367 }
2368 }
2369
2370 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2371 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2372 the unpacked buffer.
2373
2374 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2375 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2376
2377 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2378 zero otherwise.
2379
2380 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2381
2382 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2383
2384 static void
2385 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2386 gdb_byte *unpacked, int unpacked_len,
2387 int is_big_endian, int is_signed_type,
2388 int is_scalar)
2389 {
2390 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2391 int src_idx; /* Index into the source area */
2392 int src_bytes_left; /* Number of source bytes left to process. */
2393 int srcBitsLeft; /* Number of source bits left to move */
2394 int unusedLS; /* Number of bits in next significant
2395 byte of source that are unused */
2396
2397 int unpacked_idx; /* Index into the unpacked buffer */
2398 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2399
2400 unsigned long accum; /* Staging area for bits being transferred */
2401 int accumSize; /* Number of meaningful bits in accum */
2402 unsigned char sign;
2403
2404 /* Transmit bytes from least to most significant; delta is the direction
2405 the indices move. */
2406 int delta = is_big_endian ? -1 : 1;
2407
2408 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2409 bits from SRC. .*/
2410 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2411 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2412 bit_size, unpacked_len);
2413
2414 srcBitsLeft = bit_size;
2415 src_bytes_left = src_len;
2416 unpacked_bytes_left = unpacked_len;
2417 sign = 0;
2418
2419 if (is_big_endian)
2420 {
2421 src_idx = src_len - 1;
2422 if (is_signed_type
2423 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2424 sign = ~0;
2425
2426 unusedLS =
2427 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2428 % HOST_CHAR_BIT;
2429
2430 if (is_scalar)
2431 {
2432 accumSize = 0;
2433 unpacked_idx = unpacked_len - 1;
2434 }
2435 else
2436 {
2437 /* Non-scalar values must be aligned at a byte boundary... */
2438 accumSize =
2439 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2440 /* ... And are placed at the beginning (most-significant) bytes
2441 of the target. */
2442 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2443 unpacked_bytes_left = unpacked_idx + 1;
2444 }
2445 }
2446 else
2447 {
2448 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2449
2450 src_idx = unpacked_idx = 0;
2451 unusedLS = bit_offset;
2452 accumSize = 0;
2453
2454 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2455 sign = ~0;
2456 }
2457
2458 accum = 0;
2459 while (src_bytes_left > 0)
2460 {
2461 /* Mask for removing bits of the next source byte that are not
2462 part of the value. */
2463 unsigned int unusedMSMask =
2464 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2465 1;
2466 /* Sign-extend bits for this byte. */
2467 unsigned int signMask = sign & ~unusedMSMask;
2468
2469 accum |=
2470 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2471 accumSize += HOST_CHAR_BIT - unusedLS;
2472 if (accumSize >= HOST_CHAR_BIT)
2473 {
2474 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2475 accumSize -= HOST_CHAR_BIT;
2476 accum >>= HOST_CHAR_BIT;
2477 unpacked_bytes_left -= 1;
2478 unpacked_idx += delta;
2479 }
2480 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2481 unusedLS = 0;
2482 src_bytes_left -= 1;
2483 src_idx += delta;
2484 }
2485 while (unpacked_bytes_left > 0)
2486 {
2487 accum |= sign << accumSize;
2488 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2489 accumSize -= HOST_CHAR_BIT;
2490 if (accumSize < 0)
2491 accumSize = 0;
2492 accum >>= HOST_CHAR_BIT;
2493 unpacked_bytes_left -= 1;
2494 unpacked_idx += delta;
2495 }
2496 }
2497
2498 /* Create a new value of type TYPE from the contents of OBJ starting
2499 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2500 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2501 assigning through the result will set the field fetched from.
2502 VALADDR is ignored unless OBJ is NULL, in which case,
2503 VALADDR+OFFSET must address the start of storage containing the
2504 packed value. The value returned in this case is never an lval.
2505 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2506
2507 struct value *
2508 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2509 long offset, int bit_offset, int bit_size,
2510 struct type *type)
2511 {
2512 struct value *v;
2513 const gdb_byte *src; /* First byte containing data to unpack */
2514 gdb_byte *unpacked;
2515 const int is_scalar = is_scalar_type (type);
2516 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
2517 gdb::byte_vector staging;
2518
2519 type = ada_check_typedef (type);
2520
2521 if (obj == NULL)
2522 src = valaddr + offset;
2523 else
2524 src = value_contents (obj) + offset;
2525
2526 if (is_dynamic_type (type))
2527 {
2528 /* The length of TYPE might by dynamic, so we need to resolve
2529 TYPE in order to know its actual size, which we then use
2530 to create the contents buffer of the value we return.
2531 The difficulty is that the data containing our object is
2532 packed, and therefore maybe not at a byte boundary. So, what
2533 we do, is unpack the data into a byte-aligned buffer, and then
2534 use that buffer as our object's value for resolving the type. */
2535 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2536 staging.resize (staging_len);
2537
2538 ada_unpack_from_contents (src, bit_offset, bit_size,
2539 staging.data (), staging.size (),
2540 is_big_endian, has_negatives (type),
2541 is_scalar);
2542 type = resolve_dynamic_type (type, staging.data (), 0);
2543 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2544 {
2545 /* This happens when the length of the object is dynamic,
2546 and is actually smaller than the space reserved for it.
2547 For instance, in an array of variant records, the bit_size
2548 we're given is the array stride, which is constant and
2549 normally equal to the maximum size of its element.
2550 But, in reality, each element only actually spans a portion
2551 of that stride. */
2552 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2553 }
2554 }
2555
2556 if (obj == NULL)
2557 {
2558 v = allocate_value (type);
2559 src = valaddr + offset;
2560 }
2561 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2562 {
2563 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2564 gdb_byte *buf;
2565
2566 v = value_at (type, value_address (obj) + offset);
2567 buf = (gdb_byte *) alloca (src_len);
2568 read_memory (value_address (v), buf, src_len);
2569 src = buf;
2570 }
2571 else
2572 {
2573 v = allocate_value (type);
2574 src = value_contents (obj) + offset;
2575 }
2576
2577 if (obj != NULL)
2578 {
2579 long new_offset = offset;
2580
2581 set_value_component_location (v, obj);
2582 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2583 set_value_bitsize (v, bit_size);
2584 if (value_bitpos (v) >= HOST_CHAR_BIT)
2585 {
2586 ++new_offset;
2587 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2588 }
2589 set_value_offset (v, new_offset);
2590
2591 /* Also set the parent value. This is needed when trying to
2592 assign a new value (in inferior memory). */
2593 set_value_parent (v, obj);
2594 }
2595 else
2596 set_value_bitsize (v, bit_size);
2597 unpacked = value_contents_writeable (v);
2598
2599 if (bit_size == 0)
2600 {
2601 memset (unpacked, 0, TYPE_LENGTH (type));
2602 return v;
2603 }
2604
2605 if (staging.size () == TYPE_LENGTH (type))
2606 {
2607 /* Small short-cut: If we've unpacked the data into a buffer
2608 of the same size as TYPE's length, then we can reuse that,
2609 instead of doing the unpacking again. */
2610 memcpy (unpacked, staging.data (), staging.size ());
2611 }
2612 else
2613 ada_unpack_from_contents (src, bit_offset, bit_size,
2614 unpacked, TYPE_LENGTH (type),
2615 is_big_endian, has_negatives (type), is_scalar);
2616
2617 return v;
2618 }
2619
2620 /* Store the contents of FROMVAL into the location of TOVAL.
2621 Return a new value with the location of TOVAL and contents of
2622 FROMVAL. Handles assignment into packed fields that have
2623 floating-point or non-scalar types. */
2624
2625 static struct value *
2626 ada_value_assign (struct value *toval, struct value *fromval)
2627 {
2628 struct type *type = value_type (toval);
2629 int bits = value_bitsize (toval);
2630
2631 toval = ada_coerce_ref (toval);
2632 fromval = ada_coerce_ref (fromval);
2633
2634 if (ada_is_direct_array_type (value_type (toval)))
2635 toval = ada_coerce_to_simple_array (toval);
2636 if (ada_is_direct_array_type (value_type (fromval)))
2637 fromval = ada_coerce_to_simple_array (fromval);
2638
2639 if (!deprecated_value_modifiable (toval))
2640 error (_("Left operand of assignment is not a modifiable lvalue."));
2641
2642 if (VALUE_LVAL (toval) == lval_memory
2643 && bits > 0
2644 && (TYPE_CODE (type) == TYPE_CODE_FLT
2645 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2646 {
2647 int len = (value_bitpos (toval)
2648 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2649 int from_size;
2650 gdb_byte *buffer = (gdb_byte *) alloca (len);
2651 struct value *val;
2652 CORE_ADDR to_addr = value_address (toval);
2653
2654 if (TYPE_CODE (type) == TYPE_CODE_FLT)
2655 fromval = value_cast (type, fromval);
2656
2657 read_memory (to_addr, buffer, len);
2658 from_size = value_bitsize (fromval);
2659 if (from_size == 0)
2660 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2661
2662 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
2663 ULONGEST from_offset = 0;
2664 if (is_big_endian && is_scalar_type (value_type (fromval)))
2665 from_offset = from_size - bits;
2666 copy_bitwise (buffer, value_bitpos (toval),
2667 value_contents (fromval), from_offset,
2668 bits, is_big_endian);
2669 write_memory_with_notification (to_addr, buffer, len);
2670
2671 val = value_copy (toval);
2672 memcpy (value_contents_raw (val), value_contents (fromval),
2673 TYPE_LENGTH (type));
2674 deprecated_set_value_type (val, type);
2675
2676 return val;
2677 }
2678
2679 return value_assign (toval, fromval);
2680 }
2681
2682
2683 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2684 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2685 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2686 COMPONENT, and not the inferior's memory. The current contents
2687 of COMPONENT are ignored.
2688
2689 Although not part of the initial design, this function also works
2690 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2691 had a null address, and COMPONENT had an address which is equal to
2692 its offset inside CONTAINER. */
2693
2694 static void
2695 value_assign_to_component (struct value *container, struct value *component,
2696 struct value *val)
2697 {
2698 LONGEST offset_in_container =
2699 (LONGEST) (value_address (component) - value_address (container));
2700 int bit_offset_in_container =
2701 value_bitpos (component) - value_bitpos (container);
2702 int bits;
2703
2704 val = value_cast (value_type (component), val);
2705
2706 if (value_bitsize (component) == 0)
2707 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2708 else
2709 bits = value_bitsize (component);
2710
2711 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2712 {
2713 int src_offset;
2714
2715 if (is_scalar_type (check_typedef (value_type (component))))
2716 src_offset
2717 = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2718 else
2719 src_offset = 0;
2720 copy_bitwise (value_contents_writeable (container) + offset_in_container,
2721 value_bitpos (container) + bit_offset_in_container,
2722 value_contents (val), src_offset, bits, 1);
2723 }
2724 else
2725 copy_bitwise (value_contents_writeable (container) + offset_in_container,
2726 value_bitpos (container) + bit_offset_in_container,
2727 value_contents (val), 0, bits, 0);
2728 }
2729
2730 /* Determine if TYPE is an access to an unconstrained array. */
2731
2732 bool
2733 ada_is_access_to_unconstrained_array (struct type *type)
2734 {
2735 return (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
2736 && is_thick_pntr (ada_typedef_target_type (type)));
2737 }
2738
2739 /* The value of the element of array ARR at the ARITY indices given in IND.
2740 ARR may be either a simple array, GNAT array descriptor, or pointer
2741 thereto. */
2742
2743 struct value *
2744 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2745 {
2746 int k;
2747 struct value *elt;
2748 struct type *elt_type;
2749
2750 elt = ada_coerce_to_simple_array (arr);
2751
2752 elt_type = ada_check_typedef (value_type (elt));
2753 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2754 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2755 return value_subscript_packed (elt, arity, ind);
2756
2757 for (k = 0; k < arity; k += 1)
2758 {
2759 struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
2760
2761 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2762 error (_("too many subscripts (%d expected)"), k);
2763
2764 elt = value_subscript (elt, pos_atr (ind[k]));
2765
2766 if (ada_is_access_to_unconstrained_array (saved_elt_type)
2767 && TYPE_CODE (value_type (elt)) != TYPE_CODE_TYPEDEF)
2768 {
2769 /* The element is a typedef to an unconstrained array,
2770 except that the value_subscript call stripped the
2771 typedef layer. The typedef layer is GNAT's way to
2772 specify that the element is, at the source level, an
2773 access to the unconstrained array, rather than the
2774 unconstrained array. So, we need to restore that
2775 typedef layer, which we can do by forcing the element's
2776 type back to its original type. Otherwise, the returned
2777 value is going to be printed as the array, rather
2778 than as an access. Another symptom of the same issue
2779 would be that an expression trying to dereference the
2780 element would also be improperly rejected. */
2781 deprecated_set_value_type (elt, saved_elt_type);
2782 }
2783
2784 elt_type = ada_check_typedef (value_type (elt));
2785 }
2786
2787 return elt;
2788 }
2789
2790 /* Assuming ARR is a pointer to a GDB array, the value of the element
2791 of *ARR at the ARITY indices given in IND.
2792 Does not read the entire array into memory.
2793
2794 Note: Unlike what one would expect, this function is used instead of
2795 ada_value_subscript for basically all non-packed array types. The reason
2796 for this is that a side effect of doing our own pointer arithmetics instead
2797 of relying on value_subscript is that there is no implicit typedef peeling.
2798 This is important for arrays of array accesses, where it allows us to
2799 preserve the fact that the array's element is an array access, where the
2800 access part os encoded in a typedef layer. */
2801
2802 static struct value *
2803 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
2804 {
2805 int k;
2806 struct value *array_ind = ada_value_ind (arr);
2807 struct type *type
2808 = check_typedef (value_enclosing_type (array_ind));
2809
2810 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2811 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2812 return value_subscript_packed (array_ind, arity, ind);
2813
2814 for (k = 0; k < arity; k += 1)
2815 {
2816 LONGEST lwb, upb;
2817 struct value *lwb_value;
2818
2819 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2820 error (_("too many subscripts (%d expected)"), k);
2821 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2822 value_copy (arr));
2823 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2824 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2825 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
2826 type = TYPE_TARGET_TYPE (type);
2827 }
2828
2829 return value_ind (arr);
2830 }
2831
2832 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2833 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2834 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2835 this array is LOW, as per Ada rules. */
2836 static struct value *
2837 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2838 int low, int high)
2839 {
2840 struct type *type0 = ada_check_typedef (type);
2841 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
2842 struct type *index_type
2843 = create_static_range_type (NULL, base_index_type, low, high);
2844 struct type *slice_type = create_array_type_with_stride
2845 (NULL, TYPE_TARGET_TYPE (type0), index_type,
2846 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0),
2847 TYPE_FIELD_BITSIZE (type0, 0));
2848 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2849 LONGEST base_low_pos, low_pos;
2850 CORE_ADDR base;
2851
2852 if (!discrete_position (base_index_type, low, &low_pos)
2853 || !discrete_position (base_index_type, base_low, &base_low_pos))
2854 {
2855 warning (_("unable to get positions in slice, use bounds instead"));
2856 low_pos = low;
2857 base_low_pos = base_low;
2858 }
2859
2860 base = value_as_address (array_ptr)
2861 + ((low_pos - base_low_pos)
2862 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
2863 return value_at_lazy (slice_type, base);
2864 }
2865
2866
2867 static struct value *
2868 ada_value_slice (struct value *array, int low, int high)
2869 {
2870 struct type *type = ada_check_typedef (value_type (array));
2871 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2872 struct type *index_type
2873 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2874 struct type *slice_type = create_array_type_with_stride
2875 (NULL, TYPE_TARGET_TYPE (type), index_type,
2876 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type),
2877 TYPE_FIELD_BITSIZE (type, 0));
2878 LONGEST low_pos, high_pos;
2879
2880 if (!discrete_position (base_index_type, low, &low_pos)
2881 || !discrete_position (base_index_type, high, &high_pos))
2882 {
2883 warning (_("unable to get positions in slice, use bounds instead"));
2884 low_pos = low;
2885 high_pos = high;
2886 }
2887
2888 return value_cast (slice_type,
2889 value_slice (array, low, high_pos - low_pos + 1));
2890 }
2891
2892 /* If type is a record type in the form of a standard GNAT array
2893 descriptor, returns the number of dimensions for type. If arr is a
2894 simple array, returns the number of "array of"s that prefix its
2895 type designation. Otherwise, returns 0. */
2896
2897 int
2898 ada_array_arity (struct type *type)
2899 {
2900 int arity;
2901
2902 if (type == NULL)
2903 return 0;
2904
2905 type = desc_base_type (type);
2906
2907 arity = 0;
2908 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2909 return desc_arity (desc_bounds_type (type));
2910 else
2911 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2912 {
2913 arity += 1;
2914 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2915 }
2916
2917 return arity;
2918 }
2919
2920 /* If TYPE is a record type in the form of a standard GNAT array
2921 descriptor or a simple array type, returns the element type for
2922 TYPE after indexing by NINDICES indices, or by all indices if
2923 NINDICES is -1. Otherwise, returns NULL. */
2924
2925 struct type *
2926 ada_array_element_type (struct type *type, int nindices)
2927 {
2928 type = desc_base_type (type);
2929
2930 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2931 {
2932 int k;
2933 struct type *p_array_type;
2934
2935 p_array_type = desc_data_target_type (type);
2936
2937 k = ada_array_arity (type);
2938 if (k == 0)
2939 return NULL;
2940
2941 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2942 if (nindices >= 0 && k > nindices)
2943 k = nindices;
2944 while (k > 0 && p_array_type != NULL)
2945 {
2946 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2947 k -= 1;
2948 }
2949 return p_array_type;
2950 }
2951 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2952 {
2953 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
2954 {
2955 type = TYPE_TARGET_TYPE (type);
2956 nindices -= 1;
2957 }
2958 return type;
2959 }
2960
2961 return NULL;
2962 }
2963
2964 /* The type of nth index in arrays of given type (n numbering from 1).
2965 Does not examine memory. Throws an error if N is invalid or TYPE
2966 is not an array type. NAME is the name of the Ada attribute being
2967 evaluated ('range, 'first, 'last, or 'length); it is used in building
2968 the error message. */
2969
2970 static struct type *
2971 ada_index_type (struct type *type, int n, const char *name)
2972 {
2973 struct type *result_type;
2974
2975 type = desc_base_type (type);
2976
2977 if (n < 0 || n > ada_array_arity (type))
2978 error (_("invalid dimension number to '%s"), name);
2979
2980 if (ada_is_simple_array_type (type))
2981 {
2982 int i;
2983
2984 for (i = 1; i < n; i += 1)
2985 type = TYPE_TARGET_TYPE (type);
2986 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2987 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2988 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2989 perhaps stabsread.c would make more sense. */
2990 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2991 result_type = NULL;
2992 }
2993 else
2994 {
2995 result_type = desc_index_type (desc_bounds_type (type), n);
2996 if (result_type == NULL)
2997 error (_("attempt to take bound of something that is not an array"));
2998 }
2999
3000 return result_type;
3001 }
3002
3003 /* Given that arr is an array type, returns the lower bound of the
3004 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3005 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
3006 array-descriptor type. It works for other arrays with bounds supplied
3007 by run-time quantities other than discriminants. */
3008
3009 static LONGEST
3010 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3011 {
3012 struct type *type, *index_type_desc, *index_type;
3013 int i;
3014
3015 gdb_assert (which == 0 || which == 1);
3016
3017 if (ada_is_constrained_packed_array_type (arr_type))
3018 arr_type = decode_constrained_packed_array_type (arr_type);
3019
3020 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3021 return (LONGEST) - which;
3022
3023 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3024 type = TYPE_TARGET_TYPE (arr_type);
3025 else
3026 type = arr_type;
3027
3028 if (TYPE_FIXED_INSTANCE (type))
3029 {
3030 /* The array has already been fixed, so we do not need to
3031 check the parallel ___XA type again. That encoding has
3032 already been applied, so ignore it now. */
3033 index_type_desc = NULL;
3034 }
3035 else
3036 {
3037 index_type_desc = ada_find_parallel_type (type, "___XA");
3038 ada_fixup_array_indexes_type (index_type_desc);
3039 }
3040
3041 if (index_type_desc != NULL)
3042 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3043 NULL);
3044 else
3045 {
3046 struct type *elt_type = check_typedef (type);
3047
3048 for (i = 1; i < n; i++)
3049 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3050
3051 index_type = TYPE_INDEX_TYPE (elt_type);
3052 }
3053
3054 return
3055 (LONGEST) (which == 0
3056 ? ada_discrete_type_low_bound (index_type)
3057 : ada_discrete_type_high_bound (index_type));
3058 }
3059
3060 /* Given that arr is an array value, returns the lower bound of the
3061 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3062 WHICH is 1. This routine will also work for arrays with bounds
3063 supplied by run-time quantities other than discriminants. */
3064
3065 static LONGEST
3066 ada_array_bound (struct value *arr, int n, int which)
3067 {
3068 struct type *arr_type;
3069
3070 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3071 arr = value_ind (arr);
3072 arr_type = value_enclosing_type (arr);
3073
3074 if (ada_is_constrained_packed_array_type (arr_type))
3075 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3076 else if (ada_is_simple_array_type (arr_type))
3077 return ada_array_bound_from_type (arr_type, n, which);
3078 else
3079 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3080 }
3081
3082 /* Given that arr is an array value, returns the length of the
3083 nth index. This routine will also work for arrays with bounds
3084 supplied by run-time quantities other than discriminants.
3085 Does not work for arrays indexed by enumeration types with representation
3086 clauses at the moment. */
3087
3088 static LONGEST
3089 ada_array_length (struct value *arr, int n)
3090 {
3091 struct type *arr_type, *index_type;
3092 int low, high;
3093
3094 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3095 arr = value_ind (arr);
3096 arr_type = value_enclosing_type (arr);
3097
3098 if (ada_is_constrained_packed_array_type (arr_type))
3099 return ada_array_length (decode_constrained_packed_array (arr), n);
3100
3101 if (ada_is_simple_array_type (arr_type))
3102 {
3103 low = ada_array_bound_from_type (arr_type, n, 0);
3104 high = ada_array_bound_from_type (arr_type, n, 1);
3105 }
3106 else
3107 {
3108 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3109 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3110 }
3111
3112 arr_type = check_typedef (arr_type);
3113 index_type = ada_index_type (arr_type, n, "length");
3114 if (index_type != NULL)
3115 {
3116 struct type *base_type;
3117 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3118 base_type = TYPE_TARGET_TYPE (index_type);
3119 else
3120 base_type = index_type;
3121
3122 low = pos_atr (value_from_longest (base_type, low));
3123 high = pos_atr (value_from_longest (base_type, high));
3124 }
3125 return high - low + 1;
3126 }
3127
3128 /* An array whose type is that of ARR_TYPE (an array type), with
3129 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3130 less than LOW, then LOW-1 is used. */
3131
3132 static struct value *
3133 empty_array (struct type *arr_type, int low, int high)
3134 {
3135 struct type *arr_type0 = ada_check_typedef (arr_type);
3136 struct type *index_type
3137 = create_static_range_type
3138 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low,
3139 high < low ? low - 1 : high);
3140 struct type *elt_type = ada_array_element_type (arr_type0, 1);
3141
3142 return allocate_value (create_array_type (NULL, elt_type, index_type));
3143 }
3144 \f
3145
3146 /* Name resolution */
3147
3148 /* The "decoded" name for the user-definable Ada operator corresponding
3149 to OP. */
3150
3151 static const char *
3152 ada_decoded_op_name (enum exp_opcode op)
3153 {
3154 int i;
3155
3156 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3157 {
3158 if (ada_opname_table[i].op == op)
3159 return ada_opname_table[i].decoded;
3160 }
3161 error (_("Could not find operator name for opcode"));
3162 }
3163
3164
3165 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3166 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3167 undefined namespace) and converts operators that are
3168 user-defined into appropriate function calls. If CONTEXT_TYPE is
3169 non-null, it provides a preferred result type [at the moment, only
3170 type void has any effect---causing procedures to be preferred over
3171 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3172 return type is preferred. May change (expand) *EXP. */
3173
3174 static void
3175 resolve (expression_up *expp, int void_context_p, int parse_completion,
3176 innermost_block_tracker *tracker)
3177 {
3178 struct type *context_type = NULL;
3179 int pc = 0;
3180
3181 if (void_context_p)
3182 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3183
3184 resolve_subexp (expp, &pc, 1, context_type, parse_completion, tracker);
3185 }
3186
3187 /* Resolve the operator of the subexpression beginning at
3188 position *POS of *EXPP. "Resolving" consists of replacing
3189 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3190 with their resolutions, replacing built-in operators with
3191 function calls to user-defined operators, where appropriate, and,
3192 when DEPROCEDURE_P is non-zero, converting function-valued variables
3193 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3194 are as in ada_resolve, above. */
3195
3196 static struct value *
3197 resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
3198 struct type *context_type, int parse_completion,
3199 innermost_block_tracker *tracker)
3200 {
3201 int pc = *pos;
3202 int i;
3203 struct expression *exp; /* Convenience: == *expp. */
3204 enum exp_opcode op = (*expp)->elts[pc].opcode;
3205 struct value **argvec; /* Vector of operand types (alloca'ed). */
3206 int nargs; /* Number of operands. */
3207 int oplen;
3208
3209 argvec = NULL;
3210 nargs = 0;
3211 exp = expp->get ();
3212
3213 /* Pass one: resolve operands, saving their types and updating *pos,
3214 if needed. */
3215 switch (op)
3216 {
3217 case OP_FUNCALL:
3218 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3219 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3220 *pos += 7;
3221 else
3222 {
3223 *pos += 3;
3224 resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
3225 }
3226 nargs = longest_to_int (exp->elts[pc + 1].longconst);
3227 break;
3228
3229 case UNOP_ADDR:
3230 *pos += 1;
3231 resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
3232 break;
3233
3234 case UNOP_QUAL:
3235 *pos += 3;
3236 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type),
3237 parse_completion, tracker);
3238 break;
3239
3240 case OP_ATR_MODULUS:
3241 case OP_ATR_SIZE:
3242 case OP_ATR_TAG:
3243 case OP_ATR_FIRST:
3244 case OP_ATR_LAST:
3245 case OP_ATR_LENGTH:
3246 case OP_ATR_POS:
3247 case OP_ATR_VAL:
3248 case OP_ATR_MIN:
3249 case OP_ATR_MAX:
3250 case TERNOP_IN_RANGE:
3251 case BINOP_IN_BOUNDS:
3252 case UNOP_IN_RANGE:
3253 case OP_AGGREGATE:
3254 case OP_OTHERS:
3255 case OP_CHOICES:
3256 case OP_POSITIONAL:
3257 case OP_DISCRETE_RANGE:
3258 case OP_NAME:
3259 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3260 *pos += oplen;
3261 break;
3262
3263 case BINOP_ASSIGN:
3264 {
3265 struct value *arg1;
3266
3267 *pos += 1;
3268 arg1 = resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
3269 if (arg1 == NULL)
3270 resolve_subexp (expp, pos, 1, NULL, parse_completion, tracker);
3271 else
3272 resolve_subexp (expp, pos, 1, value_type (arg1), parse_completion,
3273 tracker);
3274 break;
3275 }
3276
3277 case UNOP_CAST:
3278 *pos += 3;
3279 nargs = 1;
3280 break;
3281
3282 case BINOP_ADD:
3283 case BINOP_SUB:
3284 case BINOP_MUL:
3285 case BINOP_DIV:
3286 case BINOP_REM:
3287 case BINOP_MOD:
3288 case BINOP_EXP:
3289 case BINOP_CONCAT:
3290 case BINOP_LOGICAL_AND:
3291 case BINOP_LOGICAL_OR:
3292 case BINOP_BITWISE_AND:
3293 case BINOP_BITWISE_IOR:
3294 case BINOP_BITWISE_XOR:
3295
3296 case BINOP_EQUAL:
3297 case BINOP_NOTEQUAL:
3298 case BINOP_LESS:
3299 case BINOP_GTR:
3300 case BINOP_LEQ:
3301 case BINOP_GEQ:
3302
3303 case BINOP_REPEAT:
3304 case BINOP_SUBSCRIPT:
3305 case BINOP_COMMA:
3306 *pos += 1;
3307 nargs = 2;
3308 break;
3309
3310 case UNOP_NEG:
3311 case UNOP_PLUS:
3312 case UNOP_LOGICAL_NOT:
3313 case UNOP_ABS:
3314 case UNOP_IND:
3315 *pos += 1;
3316 nargs = 1;
3317 break;
3318
3319 case OP_LONG:
3320 case OP_FLOAT:
3321 case OP_VAR_VALUE:
3322 case OP_VAR_MSYM_VALUE:
3323 *pos += 4;
3324 break;
3325
3326 case OP_TYPE:
3327 case OP_BOOL:
3328 case OP_LAST:
3329 case OP_INTERNALVAR:
3330 *pos += 3;
3331 break;
3332
3333 case UNOP_MEMVAL:
3334 *pos += 3;
3335 nargs = 1;
3336 break;
3337
3338 case OP_REGISTER:
3339 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3340 break;
3341
3342 case STRUCTOP_STRUCT:
3343 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3344 nargs = 1;
3345 break;
3346
3347 case TERNOP_SLICE:
3348 *pos += 1;
3349 nargs = 3;
3350 break;
3351
3352 case OP_STRING:
3353 break;
3354
3355 default:
3356 error (_("Unexpected operator during name resolution"));
3357 }
3358
3359 argvec = XALLOCAVEC (struct value *, nargs + 1);
3360 for (i = 0; i < nargs; i += 1)
3361 argvec[i] = resolve_subexp (expp, pos, 1, NULL, parse_completion,
3362 tracker);
3363 argvec[i] = NULL;
3364 exp = expp->get ();
3365
3366 /* Pass two: perform any resolution on principal operator. */
3367 switch (op)
3368 {
3369 default:
3370 break;
3371
3372 case OP_VAR_VALUE:
3373 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
3374 {
3375 std::vector<struct block_symbol> candidates;
3376 int n_candidates;
3377
3378 n_candidates =
3379 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3380 (exp->elts[pc + 2].symbol),
3381 exp->elts[pc + 1].block, VAR_DOMAIN,
3382 &candidates);
3383
3384 if (n_candidates > 1)
3385 {
3386 /* Types tend to get re-introduced locally, so if there
3387 are any local symbols that are not types, first filter
3388 out all types. */
3389 int j;
3390 for (j = 0; j < n_candidates; j += 1)
3391 switch (SYMBOL_CLASS (candidates[j].symbol))
3392 {
3393 case LOC_REGISTER:
3394 case LOC_ARG:
3395 case LOC_REF_ARG:
3396 case LOC_REGPARM_ADDR:
3397 case LOC_LOCAL:
3398 case LOC_COMPUTED:
3399 goto FoundNonType;
3400 default:
3401 break;
3402 }
3403 FoundNonType:
3404 if (j < n_candidates)
3405 {
3406 j = 0;
3407 while (j < n_candidates)
3408 {
3409 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
3410 {
3411 candidates[j] = candidates[n_candidates - 1];
3412 n_candidates -= 1;
3413 }
3414 else
3415 j += 1;
3416 }
3417 }
3418 }
3419
3420 if (n_candidates == 0)
3421 error (_("No definition found for %s"),
3422 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3423 else if (n_candidates == 1)
3424 i = 0;
3425 else if (deprocedure_p
3426 && !is_nonfunction (candidates.data (), n_candidates))
3427 {
3428 i = ada_resolve_function
3429 (candidates.data (), n_candidates, NULL, 0,
3430 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3431 context_type, parse_completion);
3432 if (i < 0)
3433 error (_("Could not find a match for %s"),
3434 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3435 }
3436 else
3437 {
3438 printf_filtered (_("Multiple matches for %s\n"),
3439 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3440 user_select_syms (candidates.data (), n_candidates, 1);
3441 i = 0;
3442 }
3443
3444 exp->elts[pc + 1].block = candidates[i].block;
3445 exp->elts[pc + 2].symbol = candidates[i].symbol;
3446 tracker->update (candidates[i]);
3447 }
3448
3449 if (deprocedure_p
3450 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3451 == TYPE_CODE_FUNC))
3452 {
3453 replace_operator_with_call (expp, pc, 0, 4,
3454 exp->elts[pc + 2].symbol,
3455 exp->elts[pc + 1].block);
3456 exp = expp->get ();
3457 }
3458 break;
3459
3460 case OP_FUNCALL:
3461 {
3462 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3463 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3464 {
3465 std::vector<struct block_symbol> candidates;
3466 int n_candidates;
3467
3468 n_candidates =
3469 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3470 (exp->elts[pc + 5].symbol),
3471 exp->elts[pc + 4].block, VAR_DOMAIN,
3472 &candidates);
3473
3474 if (n_candidates == 1)
3475 i = 0;
3476 else
3477 {
3478 i = ada_resolve_function
3479 (candidates.data (), n_candidates,
3480 argvec, nargs,
3481 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3482 context_type, parse_completion);
3483 if (i < 0)
3484 error (_("Could not find a match for %s"),
3485 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3486 }
3487
3488 exp->elts[pc + 4].block = candidates[i].block;
3489 exp->elts[pc + 5].symbol = candidates[i].symbol;
3490 tracker->update (candidates[i]);
3491 }
3492 }
3493 break;
3494 case BINOP_ADD:
3495 case BINOP_SUB:
3496 case BINOP_MUL:
3497 case BINOP_DIV:
3498 case BINOP_REM:
3499 case BINOP_MOD:
3500 case BINOP_CONCAT:
3501 case BINOP_BITWISE_AND:
3502 case BINOP_BITWISE_IOR:
3503 case BINOP_BITWISE_XOR:
3504 case BINOP_EQUAL:
3505 case BINOP_NOTEQUAL:
3506 case BINOP_LESS:
3507 case BINOP_GTR:
3508 case BINOP_LEQ:
3509 case BINOP_GEQ:
3510 case BINOP_EXP:
3511 case UNOP_NEG:
3512 case UNOP_PLUS:
3513 case UNOP_LOGICAL_NOT:
3514 case UNOP_ABS:
3515 if (possible_user_operator_p (op, argvec))
3516 {
3517 std::vector<struct block_symbol> candidates;
3518 int n_candidates;
3519
3520 n_candidates =
3521 ada_lookup_symbol_list (ada_decoded_op_name (op),
3522 NULL, VAR_DOMAIN,
3523 &candidates);
3524
3525 i = ada_resolve_function (candidates.data (), n_candidates, argvec,
3526 nargs, ada_decoded_op_name (op), NULL,
3527 parse_completion);
3528 if (i < 0)
3529 break;
3530
3531 replace_operator_with_call (expp, pc, nargs, 1,
3532 candidates[i].symbol,
3533 candidates[i].block);
3534 exp = expp->get ();
3535 }
3536 break;
3537
3538 case OP_TYPE:
3539 case OP_REGISTER:
3540 return NULL;
3541 }
3542
3543 *pos = pc;
3544 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3545 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3546 exp->elts[pc + 1].objfile,
3547 exp->elts[pc + 2].msymbol);
3548 else
3549 return evaluate_subexp_type (exp, pos);
3550 }
3551
3552 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3553 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3554 a non-pointer. */
3555 /* The term "match" here is rather loose. The match is heuristic and
3556 liberal. */
3557
3558 static int
3559 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
3560 {
3561 ftype = ada_check_typedef (ftype);
3562 atype = ada_check_typedef (atype);
3563
3564 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3565 ftype = TYPE_TARGET_TYPE (ftype);
3566 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3567 atype = TYPE_TARGET_TYPE (atype);
3568
3569 switch (TYPE_CODE (ftype))
3570 {
3571 default:
3572 return TYPE_CODE (ftype) == TYPE_CODE (atype);
3573 case TYPE_CODE_PTR:
3574 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
3575 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3576 TYPE_TARGET_TYPE (atype), 0);
3577 else
3578 return (may_deref
3579 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3580 case TYPE_CODE_INT:
3581 case TYPE_CODE_ENUM:
3582 case TYPE_CODE_RANGE:
3583 switch (TYPE_CODE (atype))
3584 {
3585 case TYPE_CODE_INT:
3586 case TYPE_CODE_ENUM:
3587 case TYPE_CODE_RANGE:
3588 return 1;
3589 default:
3590 return 0;
3591 }
3592
3593 case TYPE_CODE_ARRAY:
3594 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3595 || ada_is_array_descriptor_type (atype));
3596
3597 case TYPE_CODE_STRUCT:
3598 if (ada_is_array_descriptor_type (ftype))
3599 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3600 || ada_is_array_descriptor_type (atype));
3601 else
3602 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3603 && !ada_is_array_descriptor_type (atype));
3604
3605 case TYPE_CODE_UNION:
3606 case TYPE_CODE_FLT:
3607 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3608 }
3609 }
3610
3611 /* Return non-zero if the formals of FUNC "sufficiently match" the
3612 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3613 may also be an enumeral, in which case it is treated as a 0-
3614 argument function. */
3615
3616 static int
3617 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3618 {
3619 int i;
3620 struct type *func_type = SYMBOL_TYPE (func);
3621
3622 if (SYMBOL_CLASS (func) == LOC_CONST
3623 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3624 return (n_actuals == 0);
3625 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3626 return 0;
3627
3628 if (TYPE_NFIELDS (func_type) != n_actuals)
3629 return 0;
3630
3631 for (i = 0; i < n_actuals; i += 1)
3632 {
3633 if (actuals[i] == NULL)
3634 return 0;
3635 else
3636 {
3637 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3638 i));
3639 struct type *atype = ada_check_typedef (value_type (actuals[i]));
3640
3641 if (!ada_type_match (ftype, atype, 1))
3642 return 0;
3643 }
3644 }
3645 return 1;
3646 }
3647
3648 /* False iff function type FUNC_TYPE definitely does not produce a value
3649 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3650 FUNC_TYPE is not a valid function type with a non-null return type
3651 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3652
3653 static int
3654 return_match (struct type *func_type, struct type *context_type)
3655 {
3656 struct type *return_type;
3657
3658 if (func_type == NULL)
3659 return 1;
3660
3661 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3662 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3663 else
3664 return_type = get_base_type (func_type);
3665 if (return_type == NULL)
3666 return 1;
3667
3668 context_type = get_base_type (context_type);
3669
3670 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3671 return context_type == NULL || return_type == context_type;
3672 else if (context_type == NULL)
3673 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3674 else
3675 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3676 }
3677
3678
3679 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3680 function (if any) that matches the types of the NARGS arguments in
3681 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3682 that returns that type, then eliminate matches that don't. If
3683 CONTEXT_TYPE is void and there is at least one match that does not
3684 return void, eliminate all matches that do.
3685
3686 Asks the user if there is more than one match remaining. Returns -1
3687 if there is no such symbol or none is selected. NAME is used
3688 solely for messages. May re-arrange and modify SYMS in
3689 the process; the index returned is for the modified vector. */
3690
3691 static int
3692 ada_resolve_function (struct block_symbol syms[],
3693 int nsyms, struct value **args, int nargs,
3694 const char *name, struct type *context_type,
3695 int parse_completion)
3696 {
3697 int fallback;
3698 int k;
3699 int m; /* Number of hits */
3700
3701 m = 0;
3702 /* In the first pass of the loop, we only accept functions matching
3703 context_type. If none are found, we add a second pass of the loop
3704 where every function is accepted. */
3705 for (fallback = 0; m == 0 && fallback < 2; fallback++)
3706 {
3707 for (k = 0; k < nsyms; k += 1)
3708 {
3709 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
3710
3711 if (ada_args_match (syms[k].symbol, args, nargs)
3712 && (fallback || return_match (type, context_type)))
3713 {
3714 syms[m] = syms[k];
3715 m += 1;
3716 }
3717 }
3718 }
3719
3720 /* If we got multiple matches, ask the user which one to use. Don't do this
3721 interactive thing during completion, though, as the purpose of the
3722 completion is providing a list of all possible matches. Prompting the
3723 user to filter it down would be completely unexpected in this case. */
3724 if (m == 0)
3725 return -1;
3726 else if (m > 1 && !parse_completion)
3727 {
3728 printf_filtered (_("Multiple matches for %s\n"), name);
3729 user_select_syms (syms, m, 1);
3730 return 0;
3731 }
3732 return 0;
3733 }
3734
3735 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3736 in a listing of choices during disambiguation (see sort_choices, below).
3737 The idea is that overloadings of a subprogram name from the
3738 same package should sort in their source order. We settle for ordering
3739 such symbols by their trailing number (__N or $N). */
3740
3741 static int
3742 encoded_ordered_before (const char *N0, const char *N1)
3743 {
3744 if (N1 == NULL)
3745 return 0;
3746 else if (N0 == NULL)
3747 return 1;
3748 else
3749 {
3750 int k0, k1;
3751
3752 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3753 ;
3754 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3755 ;
3756 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3757 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3758 {
3759 int n0, n1;
3760
3761 n0 = k0;
3762 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3763 n0 -= 1;
3764 n1 = k1;
3765 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3766 n1 -= 1;
3767 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3768 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3769 }
3770 return (strcmp (N0, N1) < 0);
3771 }
3772 }
3773
3774 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3775 encoded names. */
3776
3777 static void
3778 sort_choices (struct block_symbol syms[], int nsyms)
3779 {
3780 int i;
3781
3782 for (i = 1; i < nsyms; i += 1)
3783 {
3784 struct block_symbol sym = syms[i];
3785 int j;
3786
3787 for (j = i - 1; j >= 0; j -= 1)
3788 {
3789 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3790 SYMBOL_LINKAGE_NAME (sym.symbol)))
3791 break;
3792 syms[j + 1] = syms[j];
3793 }
3794 syms[j + 1] = sym;
3795 }
3796 }
3797
3798 /* Whether GDB should display formals and return types for functions in the
3799 overloads selection menu. */
3800 static int print_signatures = 1;
3801
3802 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3803 all but functions, the signature is just the name of the symbol. For
3804 functions, this is the name of the function, the list of types for formals
3805 and the return type (if any). */
3806
3807 static void
3808 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3809 const struct type_print_options *flags)
3810 {
3811 struct type *type = SYMBOL_TYPE (sym);
3812
3813 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3814 if (!print_signatures
3815 || type == NULL
3816 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3817 return;
3818
3819 if (TYPE_NFIELDS (type) > 0)
3820 {
3821 int i;
3822
3823 fprintf_filtered (stream, " (");
3824 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3825 {
3826 if (i > 0)
3827 fprintf_filtered (stream, "; ");
3828 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3829 flags);
3830 }
3831 fprintf_filtered (stream, ")");
3832 }
3833 if (TYPE_TARGET_TYPE (type) != NULL
3834 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3835 {
3836 fprintf_filtered (stream, " return ");
3837 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3838 }
3839 }
3840
3841 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3842 by asking the user (if necessary), returning the number selected,
3843 and setting the first elements of SYMS items. Error if no symbols
3844 selected. */
3845
3846 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3847 to be re-integrated one of these days. */
3848
3849 int
3850 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3851 {
3852 int i;
3853 int *chosen = XALLOCAVEC (int , nsyms);
3854 int n_chosen;
3855 int first_choice = (max_results == 1) ? 1 : 2;
3856 const char *select_mode = multiple_symbols_select_mode ();
3857
3858 if (max_results < 1)
3859 error (_("Request to select 0 symbols!"));
3860 if (nsyms <= 1)
3861 return nsyms;
3862
3863 if (select_mode == multiple_symbols_cancel)
3864 error (_("\
3865 canceled because the command is ambiguous\n\
3866 See set/show multiple-symbol."));
3867
3868 /* If select_mode is "all", then return all possible symbols.
3869 Only do that if more than one symbol can be selected, of course.
3870 Otherwise, display the menu as usual. */
3871 if (select_mode == multiple_symbols_all && max_results > 1)
3872 return nsyms;
3873
3874 printf_filtered (_("[0] cancel\n"));
3875 if (max_results > 1)
3876 printf_filtered (_("[1] all\n"));
3877
3878 sort_choices (syms, nsyms);
3879
3880 for (i = 0; i < nsyms; i += 1)
3881 {
3882 if (syms[i].symbol == NULL)
3883 continue;
3884
3885 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
3886 {
3887 struct symtab_and_line sal =
3888 find_function_start_sal (syms[i].symbol, 1);
3889
3890 printf_filtered ("[%d] ", i + first_choice);
3891 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3892 &type_print_raw_options);
3893 if (sal.symtab == NULL)
3894 printf_filtered (_(" at <no source file available>:%d\n"),
3895 sal.line);
3896 else
3897 printf_filtered (_(" at %s:%d\n"),
3898 symtab_to_filename_for_display (sal.symtab),
3899 sal.line);
3900 continue;
3901 }
3902 else
3903 {
3904 int is_enumeral =
3905 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3906 && SYMBOL_TYPE (syms[i].symbol) != NULL
3907 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
3908 struct symtab *symtab = NULL;
3909
3910 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3911 symtab = symbol_symtab (syms[i].symbol);
3912
3913 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
3914 {
3915 printf_filtered ("[%d] ", i + first_choice);
3916 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3917 &type_print_raw_options);
3918 printf_filtered (_(" at %s:%d\n"),
3919 symtab_to_filename_for_display (symtab),
3920 SYMBOL_LINE (syms[i].symbol));
3921 }
3922 else if (is_enumeral
3923 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
3924 {
3925 printf_filtered (("[%d] "), i + first_choice);
3926 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
3927 gdb_stdout, -1, 0, &type_print_raw_options);
3928 printf_filtered (_("'(%s) (enumeral)\n"),
3929 SYMBOL_PRINT_NAME (syms[i].symbol));
3930 }
3931 else
3932 {
3933 printf_filtered ("[%d] ", i + first_choice);
3934 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3935 &type_print_raw_options);
3936
3937 if (symtab != NULL)
3938 printf_filtered (is_enumeral
3939 ? _(" in %s (enumeral)\n")
3940 : _(" at %s:?\n"),
3941 symtab_to_filename_for_display (symtab));
3942 else
3943 printf_filtered (is_enumeral
3944 ? _(" (enumeral)\n")
3945 : _(" at ?\n"));
3946 }
3947 }
3948 }
3949
3950 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3951 "overload-choice");
3952
3953 for (i = 0; i < n_chosen; i += 1)
3954 syms[i] = syms[chosen[i]];
3955
3956 return n_chosen;
3957 }
3958
3959 /* Read and validate a set of numeric choices from the user in the
3960 range 0 .. N_CHOICES-1. Place the results in increasing
3961 order in CHOICES[0 .. N-1], and return N.
3962
3963 The user types choices as a sequence of numbers on one line
3964 separated by blanks, encoding them as follows:
3965
3966 + A choice of 0 means to cancel the selection, throwing an error.
3967 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3968 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3969
3970 The user is not allowed to choose more than MAX_RESULTS values.
3971
3972 ANNOTATION_SUFFIX, if present, is used to annotate the input
3973 prompts (for use with the -f switch). */
3974
3975 int
3976 get_selections (int *choices, int n_choices, int max_results,
3977 int is_all_choice, const char *annotation_suffix)
3978 {
3979 char *args;
3980 const char *prompt;
3981 int n_chosen;
3982 int first_choice = is_all_choice ? 2 : 1;
3983
3984 prompt = getenv ("PS2");
3985 if (prompt == NULL)
3986 prompt = "> ";
3987
3988 args = command_line_input (prompt, annotation_suffix);
3989
3990 if (args == NULL)
3991 error_no_arg (_("one or more choice numbers"));
3992
3993 n_chosen = 0;
3994
3995 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3996 order, as given in args. Choices are validated. */
3997 while (1)
3998 {
3999 char *args2;
4000 int choice, j;
4001
4002 args = skip_spaces (args);
4003 if (*args == '\0' && n_chosen == 0)
4004 error_no_arg (_("one or more choice numbers"));
4005 else if (*args == '\0')
4006 break;
4007
4008 choice = strtol (args, &args2, 10);
4009 if (args == args2 || choice < 0
4010 || choice > n_choices + first_choice - 1)
4011 error (_("Argument must be choice number"));
4012 args = args2;
4013
4014 if (choice == 0)
4015 error (_("cancelled"));
4016
4017 if (choice < first_choice)
4018 {
4019 n_chosen = n_choices;
4020 for (j = 0; j < n_choices; j += 1)
4021 choices[j] = j;
4022 break;
4023 }
4024 choice -= first_choice;
4025
4026 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4027 {
4028 }
4029
4030 if (j < 0 || choice != choices[j])
4031 {
4032 int k;
4033
4034 for (k = n_chosen - 1; k > j; k -= 1)
4035 choices[k + 1] = choices[k];
4036 choices[j + 1] = choice;
4037 n_chosen += 1;
4038 }
4039 }
4040
4041 if (n_chosen > max_results)
4042 error (_("Select no more than %d of the above"), max_results);
4043
4044 return n_chosen;
4045 }
4046
4047 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
4048 on the function identified by SYM and BLOCK, and taking NARGS
4049 arguments. Update *EXPP as needed to hold more space. */
4050
4051 static void
4052 replace_operator_with_call (expression_up *expp, int pc, int nargs,
4053 int oplen, struct symbol *sym,
4054 const struct block *block)
4055 {
4056 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4057 symbol, -oplen for operator being replaced). */
4058 struct expression *newexp = (struct expression *)
4059 xzalloc (sizeof (struct expression)
4060 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
4061 struct expression *exp = expp->get ();
4062
4063 newexp->nelts = exp->nelts + 7 - oplen;
4064 newexp->language_defn = exp->language_defn;
4065 newexp->gdbarch = exp->gdbarch;
4066 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
4067 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4068 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
4069
4070 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4071 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4072
4073 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4074 newexp->elts[pc + 4].block = block;
4075 newexp->elts[pc + 5].symbol = sym;
4076
4077 expp->reset (newexp);
4078 }
4079
4080 /* Type-class predicates */
4081
4082 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4083 or FLOAT). */
4084
4085 static int
4086 numeric_type_p (struct type *type)
4087 {
4088 if (type == NULL)
4089 return 0;
4090 else
4091 {
4092 switch (TYPE_CODE (type))
4093 {
4094 case TYPE_CODE_INT:
4095 case TYPE_CODE_FLT:
4096 return 1;
4097 case TYPE_CODE_RANGE:
4098 return (type == TYPE_TARGET_TYPE (type)
4099 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4100 default:
4101 return 0;
4102 }
4103 }
4104 }
4105
4106 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4107
4108 static int
4109 integer_type_p (struct type *type)
4110 {
4111 if (type == NULL)
4112 return 0;
4113 else
4114 {
4115 switch (TYPE_CODE (type))
4116 {
4117 case TYPE_CODE_INT:
4118 return 1;
4119 case TYPE_CODE_RANGE:
4120 return (type == TYPE_TARGET_TYPE (type)
4121 || integer_type_p (TYPE_TARGET_TYPE (type)));
4122 default:
4123 return 0;
4124 }
4125 }
4126 }
4127
4128 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4129
4130 static int
4131 scalar_type_p (struct type *type)
4132 {
4133 if (type == NULL)
4134 return 0;
4135 else
4136 {
4137 switch (TYPE_CODE (type))
4138 {
4139 case TYPE_CODE_INT:
4140 case TYPE_CODE_RANGE:
4141 case TYPE_CODE_ENUM:
4142 case TYPE_CODE_FLT:
4143 return 1;
4144 default:
4145 return 0;
4146 }
4147 }
4148 }
4149
4150 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4151
4152 static int
4153 discrete_type_p (struct type *type)
4154 {
4155 if (type == NULL)
4156 return 0;
4157 else
4158 {
4159 switch (TYPE_CODE (type))
4160 {
4161 case TYPE_CODE_INT:
4162 case TYPE_CODE_RANGE:
4163 case TYPE_CODE_ENUM:
4164 case TYPE_CODE_BOOL:
4165 return 1;
4166 default:
4167 return 0;
4168 }
4169 }
4170 }
4171
4172 /* Returns non-zero if OP with operands in the vector ARGS could be
4173 a user-defined function. Errs on the side of pre-defined operators
4174 (i.e., result 0). */
4175
4176 static int
4177 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4178 {
4179 struct type *type0 =
4180 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4181 struct type *type1 =
4182 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4183
4184 if (type0 == NULL)
4185 return 0;
4186
4187 switch (op)
4188 {
4189 default:
4190 return 0;
4191
4192 case BINOP_ADD:
4193 case BINOP_SUB:
4194 case BINOP_MUL:
4195 case BINOP_DIV:
4196 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4197
4198 case BINOP_REM:
4199 case BINOP_MOD:
4200 case BINOP_BITWISE_AND:
4201 case BINOP_BITWISE_IOR:
4202 case BINOP_BITWISE_XOR:
4203 return (!(integer_type_p (type0) && integer_type_p (type1)));
4204
4205 case BINOP_EQUAL:
4206 case BINOP_NOTEQUAL:
4207 case BINOP_LESS:
4208 case BINOP_GTR:
4209 case BINOP_LEQ:
4210 case BINOP_GEQ:
4211 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4212
4213 case BINOP_CONCAT:
4214 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4215
4216 case BINOP_EXP:
4217 return (!(numeric_type_p (type0) && integer_type_p (type1)));
4218
4219 case UNOP_NEG:
4220 case UNOP_PLUS:
4221 case UNOP_LOGICAL_NOT:
4222 case UNOP_ABS:
4223 return (!numeric_type_p (type0));
4224
4225 }
4226 }
4227 \f
4228 /* Renaming */
4229
4230 /* NOTES:
4231
4232 1. In the following, we assume that a renaming type's name may
4233 have an ___XD suffix. It would be nice if this went away at some
4234 point.
4235 2. We handle both the (old) purely type-based representation of
4236 renamings and the (new) variable-based encoding. At some point,
4237 it is devoutly to be hoped that the former goes away
4238 (FIXME: hilfinger-2007-07-09).
4239 3. Subprogram renamings are not implemented, although the XRS
4240 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4241
4242 /* If SYM encodes a renaming,
4243
4244 <renaming> renames <renamed entity>,
4245
4246 sets *LEN to the length of the renamed entity's name,
4247 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4248 the string describing the subcomponent selected from the renamed
4249 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4250 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4251 are undefined). Otherwise, returns a value indicating the category
4252 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4253 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4254 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4255 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4256 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4257 may be NULL, in which case they are not assigned.
4258
4259 [Currently, however, GCC does not generate subprogram renamings.] */
4260
4261 enum ada_renaming_category
4262 ada_parse_renaming (struct symbol *sym,
4263 const char **renamed_entity, int *len,
4264 const char **renaming_expr)
4265 {
4266 enum ada_renaming_category kind;
4267 const char *info;
4268 const char *suffix;
4269
4270 if (sym == NULL)
4271 return ADA_NOT_RENAMING;
4272 switch (SYMBOL_CLASS (sym))
4273 {
4274 default:
4275 return ADA_NOT_RENAMING;
4276 case LOC_LOCAL:
4277 case LOC_STATIC:
4278 case LOC_COMPUTED:
4279 case LOC_OPTIMIZED_OUT:
4280 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4281 if (info == NULL)
4282 return ADA_NOT_RENAMING;
4283 switch (info[5])
4284 {
4285 case '_':
4286 kind = ADA_OBJECT_RENAMING;
4287 info += 6;
4288 break;
4289 case 'E':
4290 kind = ADA_EXCEPTION_RENAMING;
4291 info += 7;
4292 break;
4293 case 'P':
4294 kind = ADA_PACKAGE_RENAMING;
4295 info += 7;
4296 break;
4297 case 'S':
4298 kind = ADA_SUBPROGRAM_RENAMING;
4299 info += 7;
4300 break;
4301 default:
4302 return ADA_NOT_RENAMING;
4303 }
4304 }
4305
4306 if (renamed_entity != NULL)
4307 *renamed_entity = info;
4308 suffix = strstr (info, "___XE");
4309 if (suffix == NULL || suffix == info)
4310 return ADA_NOT_RENAMING;
4311 if (len != NULL)
4312 *len = strlen (info) - strlen (suffix);
4313 suffix += 5;
4314 if (renaming_expr != NULL)
4315 *renaming_expr = suffix;
4316 return kind;
4317 }
4318
4319 /* Compute the value of the given RENAMING_SYM, which is expected to
4320 be a symbol encoding a renaming expression. BLOCK is the block
4321 used to evaluate the renaming. */
4322
4323 static struct value *
4324 ada_read_renaming_var_value (struct symbol *renaming_sym,
4325 const struct block *block)
4326 {
4327 const char *sym_name;
4328
4329 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4330 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4331 return evaluate_expression (expr.get ());
4332 }
4333 \f
4334
4335 /* Evaluation: Function Calls */
4336
4337 /* Return an lvalue containing the value VAL. This is the identity on
4338 lvalues, and otherwise has the side-effect of allocating memory
4339 in the inferior where a copy of the value contents is copied. */
4340
4341 static struct value *
4342 ensure_lval (struct value *val)
4343 {
4344 if (VALUE_LVAL (val) == not_lval
4345 || VALUE_LVAL (val) == lval_internalvar)
4346 {
4347 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4348 const CORE_ADDR addr =
4349 value_as_long (value_allocate_space_in_inferior (len));
4350
4351 VALUE_LVAL (val) = lval_memory;
4352 set_value_address (val, addr);
4353 write_memory (addr, value_contents (val), len);
4354 }
4355
4356 return val;
4357 }
4358
4359 /* Return the value ACTUAL, converted to be an appropriate value for a
4360 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4361 allocating any necessary descriptors (fat pointers), or copies of
4362 values not residing in memory, updating it as needed. */
4363
4364 struct value *
4365 ada_convert_actual (struct value *actual, struct type *formal_type0)
4366 {
4367 struct type *actual_type = ada_check_typedef (value_type (actual));
4368 struct type *formal_type = ada_check_typedef (formal_type0);
4369 struct type *formal_target =
4370 TYPE_CODE (formal_type) == TYPE_CODE_PTR
4371 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4372 struct type *actual_target =
4373 TYPE_CODE (actual_type) == TYPE_CODE_PTR
4374 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4375
4376 if (ada_is_array_descriptor_type (formal_target)
4377 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
4378 return make_array_descriptor (formal_type, actual);
4379 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4380 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
4381 {
4382 struct value *result;
4383
4384 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4385 && ada_is_array_descriptor_type (actual_target))
4386 result = desc_data (actual);
4387 else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR)
4388 {
4389 if (VALUE_LVAL (actual) != lval_memory)
4390 {
4391 struct value *val;
4392
4393 actual_type = ada_check_typedef (value_type (actual));
4394 val = allocate_value (actual_type);
4395 memcpy ((char *) value_contents_raw (val),
4396 (char *) value_contents (actual),
4397 TYPE_LENGTH (actual_type));
4398 actual = ensure_lval (val);
4399 }
4400 result = value_addr (actual);
4401 }
4402 else
4403 return actual;
4404 return value_cast_pointers (formal_type, result, 0);
4405 }
4406 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4407 return ada_value_ind (actual);
4408 else if (ada_is_aligner_type (formal_type))
4409 {
4410 /* We need to turn this parameter into an aligner type
4411 as well. */
4412 struct value *aligner = allocate_value (formal_type);
4413 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4414
4415 value_assign_to_component (aligner, component, actual);
4416 return aligner;
4417 }
4418
4419 return actual;
4420 }
4421
4422 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4423 type TYPE. This is usually an inefficient no-op except on some targets
4424 (such as AVR) where the representation of a pointer and an address
4425 differs. */
4426
4427 static CORE_ADDR
4428 value_pointer (struct value *value, struct type *type)
4429 {
4430 struct gdbarch *gdbarch = get_type_arch (type);
4431 unsigned len = TYPE_LENGTH (type);
4432 gdb_byte *buf = (gdb_byte *) alloca (len);
4433 CORE_ADDR addr;
4434
4435 addr = value_address (value);
4436 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4437 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4438 return addr;
4439 }
4440
4441
4442 /* Push a descriptor of type TYPE for array value ARR on the stack at
4443 *SP, updating *SP to reflect the new descriptor. Return either
4444 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4445 to-descriptor type rather than a descriptor type), a struct value *
4446 representing a pointer to this descriptor. */
4447
4448 static struct value *
4449 make_array_descriptor (struct type *type, struct value *arr)
4450 {
4451 struct type *bounds_type = desc_bounds_type (type);
4452 struct type *desc_type = desc_base_type (type);
4453 struct value *descriptor = allocate_value (desc_type);
4454 struct value *bounds = allocate_value (bounds_type);
4455 int i;
4456
4457 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4458 i > 0; i -= 1)
4459 {
4460 modify_field (value_type (bounds), value_contents_writeable (bounds),
4461 ada_array_bound (arr, i, 0),
4462 desc_bound_bitpos (bounds_type, i, 0),
4463 desc_bound_bitsize (bounds_type, i, 0));
4464 modify_field (value_type (bounds), value_contents_writeable (bounds),
4465 ada_array_bound (arr, i, 1),
4466 desc_bound_bitpos (bounds_type, i, 1),
4467 desc_bound_bitsize (bounds_type, i, 1));
4468 }
4469
4470 bounds = ensure_lval (bounds);
4471
4472 modify_field (value_type (descriptor),
4473 value_contents_writeable (descriptor),
4474 value_pointer (ensure_lval (arr),
4475 TYPE_FIELD_TYPE (desc_type, 0)),
4476 fat_pntr_data_bitpos (desc_type),
4477 fat_pntr_data_bitsize (desc_type));
4478
4479 modify_field (value_type (descriptor),
4480 value_contents_writeable (descriptor),
4481 value_pointer (bounds,
4482 TYPE_FIELD_TYPE (desc_type, 1)),
4483 fat_pntr_bounds_bitpos (desc_type),
4484 fat_pntr_bounds_bitsize (desc_type));
4485
4486 descriptor = ensure_lval (descriptor);
4487
4488 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4489 return value_addr (descriptor);
4490 else
4491 return descriptor;
4492 }
4493 \f
4494 /* Symbol Cache Module */
4495
4496 /* Performance measurements made as of 2010-01-15 indicate that
4497 this cache does bring some noticeable improvements. Depending
4498 on the type of entity being printed, the cache can make it as much
4499 as an order of magnitude faster than without it.
4500
4501 The descriptive type DWARF extension has significantly reduced
4502 the need for this cache, at least when DWARF is being used. However,
4503 even in this case, some expensive name-based symbol searches are still
4504 sometimes necessary - to find an XVZ variable, mostly. */
4505
4506 /* Initialize the contents of SYM_CACHE. */
4507
4508 static void
4509 ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4510 {
4511 obstack_init (&sym_cache->cache_space);
4512 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4513 }
4514
4515 /* Free the memory used by SYM_CACHE. */
4516
4517 static void
4518 ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
4519 {
4520 obstack_free (&sym_cache->cache_space, NULL);
4521 xfree (sym_cache);
4522 }
4523
4524 /* Return the symbol cache associated to the given program space PSPACE.
4525 If not allocated for this PSPACE yet, allocate and initialize one. */
4526
4527 static struct ada_symbol_cache *
4528 ada_get_symbol_cache (struct program_space *pspace)
4529 {
4530 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4531
4532 if (pspace_data->sym_cache == NULL)
4533 {
4534 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4535 ada_init_symbol_cache (pspace_data->sym_cache);
4536 }
4537
4538 return pspace_data->sym_cache;
4539 }
4540
4541 /* Clear all entries from the symbol cache. */
4542
4543 static void
4544 ada_clear_symbol_cache (void)
4545 {
4546 struct ada_symbol_cache *sym_cache
4547 = ada_get_symbol_cache (current_program_space);
4548
4549 obstack_free (&sym_cache->cache_space, NULL);
4550 ada_init_symbol_cache (sym_cache);
4551 }
4552
4553 /* Search our cache for an entry matching NAME and DOMAIN.
4554 Return it if found, or NULL otherwise. */
4555
4556 static struct cache_entry **
4557 find_entry (const char *name, domain_enum domain)
4558 {
4559 struct ada_symbol_cache *sym_cache
4560 = ada_get_symbol_cache (current_program_space);
4561 int h = msymbol_hash (name) % HASH_SIZE;
4562 struct cache_entry **e;
4563
4564 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4565 {
4566 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4567 return e;
4568 }
4569 return NULL;
4570 }
4571
4572 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4573 Return 1 if found, 0 otherwise.
4574
4575 If an entry was found and SYM is not NULL, set *SYM to the entry's
4576 SYM. Same principle for BLOCK if not NULL. */
4577
4578 static int
4579 lookup_cached_symbol (const char *name, domain_enum domain,
4580 struct symbol **sym, const struct block **block)
4581 {
4582 struct cache_entry **e = find_entry (name, domain);
4583
4584 if (e == NULL)
4585 return 0;
4586 if (sym != NULL)
4587 *sym = (*e)->sym;
4588 if (block != NULL)
4589 *block = (*e)->block;
4590 return 1;
4591 }
4592
4593 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4594 in domain DOMAIN, save this result in our symbol cache. */
4595
4596 static void
4597 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4598 const struct block *block)
4599 {
4600 struct ada_symbol_cache *sym_cache
4601 = ada_get_symbol_cache (current_program_space);
4602 int h;
4603 char *copy;
4604 struct cache_entry *e;
4605
4606 /* Symbols for builtin types don't have a block.
4607 For now don't cache such symbols. */
4608 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4609 return;
4610
4611 /* If the symbol is a local symbol, then do not cache it, as a search
4612 for that symbol depends on the context. To determine whether
4613 the symbol is local or not, we check the block where we found it
4614 against the global and static blocks of its associated symtab. */
4615 if (sym
4616 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4617 GLOBAL_BLOCK) != block
4618 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4619 STATIC_BLOCK) != block)
4620 return;
4621
4622 h = msymbol_hash (name) % HASH_SIZE;
4623 e = XOBNEW (&sym_cache->cache_space, cache_entry);
4624 e->next = sym_cache->root[h];
4625 sym_cache->root[h] = e;
4626 e->name = copy
4627 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
4628 strcpy (copy, name);
4629 e->sym = sym;
4630 e->domain = domain;
4631 e->block = block;
4632 }
4633 \f
4634 /* Symbol Lookup */
4635
4636 /* Return the symbol name match type that should be used used when
4637 searching for all symbols matching LOOKUP_NAME.
4638
4639 LOOKUP_NAME is expected to be a symbol name after transformation
4640 for Ada lookups. */
4641
4642 static symbol_name_match_type
4643 name_match_type_from_name (const char *lookup_name)
4644 {
4645 return (strstr (lookup_name, "__") == NULL
4646 ? symbol_name_match_type::WILD
4647 : symbol_name_match_type::FULL);
4648 }
4649
4650 /* Return the result of a standard (literal, C-like) lookup of NAME in
4651 given DOMAIN, visible from lexical block BLOCK. */
4652
4653 static struct symbol *
4654 standard_lookup (const char *name, const struct block *block,
4655 domain_enum domain)
4656 {
4657 /* Initialize it just to avoid a GCC false warning. */
4658 struct block_symbol sym = {};
4659
4660 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4661 return sym.symbol;
4662 ada_lookup_encoded_symbol (name, block, domain, &sym);
4663 cache_symbol (name, domain, sym.symbol, sym.block);
4664 return sym.symbol;
4665 }
4666
4667
4668 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4669 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4670 since they contend in overloading in the same way. */
4671 static int
4672 is_nonfunction (struct block_symbol syms[], int n)
4673 {
4674 int i;
4675
4676 for (i = 0; i < n; i += 1)
4677 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4678 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4679 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
4680 return 1;
4681
4682 return 0;
4683 }
4684
4685 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4686 struct types. Otherwise, they may not. */
4687
4688 static int
4689 equiv_types (struct type *type0, struct type *type1)
4690 {
4691 if (type0 == type1)
4692 return 1;
4693 if (type0 == NULL || type1 == NULL
4694 || TYPE_CODE (type0) != TYPE_CODE (type1))
4695 return 0;
4696 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
4697 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4698 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4699 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4700 return 1;
4701
4702 return 0;
4703 }
4704
4705 /* True iff SYM0 represents the same entity as SYM1, or one that is
4706 no more defined than that of SYM1. */
4707
4708 static int
4709 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4710 {
4711 if (sym0 == sym1)
4712 return 1;
4713 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4714 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4715 return 0;
4716
4717 switch (SYMBOL_CLASS (sym0))
4718 {
4719 case LOC_UNDEF:
4720 return 1;
4721 case LOC_TYPEDEF:
4722 {
4723 struct type *type0 = SYMBOL_TYPE (sym0);
4724 struct type *type1 = SYMBOL_TYPE (sym1);
4725 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4726 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4727 int len0 = strlen (name0);
4728
4729 return
4730 TYPE_CODE (type0) == TYPE_CODE (type1)
4731 && (equiv_types (type0, type1)
4732 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4733 && startswith (name1 + len0, "___XV")));
4734 }
4735 case LOC_CONST:
4736 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4737 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4738 default:
4739 return 0;
4740 }
4741 }
4742
4743 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4744 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4745
4746 static void
4747 add_defn_to_vec (struct obstack *obstackp,
4748 struct symbol *sym,
4749 const struct block *block)
4750 {
4751 int i;
4752 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
4753
4754 /* Do not try to complete stub types, as the debugger is probably
4755 already scanning all symbols matching a certain name at the
4756 time when this function is called. Trying to replace the stub
4757 type by its associated full type will cause us to restart a scan
4758 which may lead to an infinite recursion. Instead, the client
4759 collecting the matching symbols will end up collecting several
4760 matches, with at least one of them complete. It can then filter
4761 out the stub ones if needed. */
4762
4763 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4764 {
4765 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4766 return;
4767 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4768 {
4769 prevDefns[i].symbol = sym;
4770 prevDefns[i].block = block;
4771 return;
4772 }
4773 }
4774
4775 {
4776 struct block_symbol info;
4777
4778 info.symbol = sym;
4779 info.block = block;
4780 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4781 }
4782 }
4783
4784 /* Number of block_symbol structures currently collected in current vector in
4785 OBSTACKP. */
4786
4787 static int
4788 num_defns_collected (struct obstack *obstackp)
4789 {
4790 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4791 }
4792
4793 /* Vector of block_symbol structures currently collected in current vector in
4794 OBSTACKP. If FINISH, close off the vector and return its final address. */
4795
4796 static struct block_symbol *
4797 defns_collected (struct obstack *obstackp, int finish)
4798 {
4799 if (finish)
4800 return (struct block_symbol *) obstack_finish (obstackp);
4801 else
4802 return (struct block_symbol *) obstack_base (obstackp);
4803 }
4804
4805 /* Return a bound minimal symbol matching NAME according to Ada
4806 decoding rules. Returns an invalid symbol if there is no such
4807 minimal symbol. Names prefixed with "standard__" are handled
4808 specially: "standard__" is first stripped off, and only static and
4809 global symbols are searched. */
4810
4811 struct bound_minimal_symbol
4812 ada_lookup_simple_minsym (const char *name)
4813 {
4814 struct bound_minimal_symbol result;
4815
4816 memset (&result, 0, sizeof (result));
4817
4818 symbol_name_match_type match_type = name_match_type_from_name (name);
4819 lookup_name_info lookup_name (name, match_type);
4820
4821 symbol_name_matcher_ftype *match_name
4822 = ada_get_symbol_name_matcher (lookup_name);
4823
4824 for (objfile *objfile : current_program_space->objfiles ())
4825 {
4826 for (minimal_symbol *msymbol : objfile->msymbols ())
4827 {
4828 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
4829 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4830 {
4831 result.minsym = msymbol;
4832 result.objfile = objfile;
4833 break;
4834 }
4835 }
4836 }
4837
4838 return result;
4839 }
4840
4841 /* Return all the bound minimal symbols matching NAME according to Ada
4842 decoding rules. Returns an empty vector if there is no such
4843 minimal symbol. Names prefixed with "standard__" are handled
4844 specially: "standard__" is first stripped off, and only static and
4845 global symbols are searched. */
4846
4847 static std::vector<struct bound_minimal_symbol>
4848 ada_lookup_simple_minsyms (const char *name)
4849 {
4850 std::vector<struct bound_minimal_symbol> result;
4851
4852 symbol_name_match_type match_type = name_match_type_from_name (name);
4853 lookup_name_info lookup_name (name, match_type);
4854
4855 symbol_name_matcher_ftype *match_name
4856 = ada_get_symbol_name_matcher (lookup_name);
4857
4858 for (objfile *objfile : current_program_space->objfiles ())
4859 {
4860 for (minimal_symbol *msymbol : objfile->msymbols ())
4861 {
4862 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
4863 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4864 result.push_back ({msymbol, objfile});
4865 }
4866 }
4867
4868 return result;
4869 }
4870
4871 /* For all subprograms that statically enclose the subprogram of the
4872 selected frame, add symbols matching identifier NAME in DOMAIN
4873 and their blocks to the list of data in OBSTACKP, as for
4874 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4875 with a wildcard prefix. */
4876
4877 static void
4878 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4879 const lookup_name_info &lookup_name,
4880 domain_enum domain)
4881 {
4882 }
4883
4884 /* True if TYPE is definitely an artificial type supplied to a symbol
4885 for which no debugging information was given in the symbol file. */
4886
4887 static int
4888 is_nondebugging_type (struct type *type)
4889 {
4890 const char *name = ada_type_name (type);
4891
4892 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4893 }
4894
4895 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4896 that are deemed "identical" for practical purposes.
4897
4898 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4899 types and that their number of enumerals is identical (in other
4900 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4901
4902 static int
4903 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4904 {
4905 int i;
4906
4907 /* The heuristic we use here is fairly conservative. We consider
4908 that 2 enumerate types are identical if they have the same
4909 number of enumerals and that all enumerals have the same
4910 underlying value and name. */
4911
4912 /* All enums in the type should have an identical underlying value. */
4913 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4914 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
4915 return 0;
4916
4917 /* All enumerals should also have the same name (modulo any numerical
4918 suffix). */
4919 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4920 {
4921 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4922 const char *name_2 = TYPE_FIELD_NAME (type2, i);
4923 int len_1 = strlen (name_1);
4924 int len_2 = strlen (name_2);
4925
4926 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4927 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4928 if (len_1 != len_2
4929 || strncmp (TYPE_FIELD_NAME (type1, i),
4930 TYPE_FIELD_NAME (type2, i),
4931 len_1) != 0)
4932 return 0;
4933 }
4934
4935 return 1;
4936 }
4937
4938 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4939 that are deemed "identical" for practical purposes. Sometimes,
4940 enumerals are not strictly identical, but their types are so similar
4941 that they can be considered identical.
4942
4943 For instance, consider the following code:
4944
4945 type Color is (Black, Red, Green, Blue, White);
4946 type RGB_Color is new Color range Red .. Blue;
4947
4948 Type RGB_Color is a subrange of an implicit type which is a copy
4949 of type Color. If we call that implicit type RGB_ColorB ("B" is
4950 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4951 As a result, when an expression references any of the enumeral
4952 by name (Eg. "print green"), the expression is technically
4953 ambiguous and the user should be asked to disambiguate. But
4954 doing so would only hinder the user, since it wouldn't matter
4955 what choice he makes, the outcome would always be the same.
4956 So, for practical purposes, we consider them as the same. */
4957
4958 static int
4959 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
4960 {
4961 int i;
4962
4963 /* Before performing a thorough comparison check of each type,
4964 we perform a series of inexpensive checks. We expect that these
4965 checks will quickly fail in the vast majority of cases, and thus
4966 help prevent the unnecessary use of a more expensive comparison.
4967 Said comparison also expects us to make some of these checks
4968 (see ada_identical_enum_types_p). */
4969
4970 /* Quick check: All symbols should have an enum type. */
4971 for (i = 0; i < syms.size (); i++)
4972 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
4973 return 0;
4974
4975 /* Quick check: They should all have the same value. */
4976 for (i = 1; i < syms.size (); i++)
4977 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
4978 return 0;
4979
4980 /* Quick check: They should all have the same number of enumerals. */
4981 for (i = 1; i < syms.size (); i++)
4982 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
4983 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
4984 return 0;
4985
4986 /* All the sanity checks passed, so we might have a set of
4987 identical enumeration types. Perform a more complete
4988 comparison of the type of each symbol. */
4989 for (i = 1; i < syms.size (); i++)
4990 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
4991 SYMBOL_TYPE (syms[0].symbol)))
4992 return 0;
4993
4994 return 1;
4995 }
4996
4997 /* Remove any non-debugging symbols in SYMS that definitely
4998 duplicate other symbols in the list (The only case I know of where
4999 this happens is when object files containing stabs-in-ecoff are
5000 linked with files containing ordinary ecoff debugging symbols (or no
5001 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5002 Returns the number of items in the modified list. */
5003
5004 static int
5005 remove_extra_symbols (std::vector<struct block_symbol> *syms)
5006 {
5007 int i, j;
5008
5009 /* We should never be called with less than 2 symbols, as there
5010 cannot be any extra symbol in that case. But it's easy to
5011 handle, since we have nothing to do in that case. */
5012 if (syms->size () < 2)
5013 return syms->size ();
5014
5015 i = 0;
5016 while (i < syms->size ())
5017 {
5018 int remove_p = 0;
5019
5020 /* If two symbols have the same name and one of them is a stub type,
5021 the get rid of the stub. */
5022
5023 if (TYPE_STUB (SYMBOL_TYPE ((*syms)[i].symbol))
5024 && SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL)
5025 {
5026 for (j = 0; j < syms->size (); j++)
5027 {
5028 if (j != i
5029 && !TYPE_STUB (SYMBOL_TYPE ((*syms)[j].symbol))
5030 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5031 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5032 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0)
5033 remove_p = 1;
5034 }
5035 }
5036
5037 /* Two symbols with the same name, same class and same address
5038 should be identical. */
5039
5040 else if (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL
5041 && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
5042 && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
5043 {
5044 for (j = 0; j < syms->size (); j += 1)
5045 {
5046 if (i != j
5047 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5048 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5049 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0
5050 && SYMBOL_CLASS ((*syms)[i].symbol)
5051 == SYMBOL_CLASS ((*syms)[j].symbol)
5052 && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
5053 == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
5054 remove_p = 1;
5055 }
5056 }
5057
5058 if (remove_p)
5059 syms->erase (syms->begin () + i);
5060
5061 i += 1;
5062 }
5063
5064 /* If all the remaining symbols are identical enumerals, then
5065 just keep the first one and discard the rest.
5066
5067 Unlike what we did previously, we do not discard any entry
5068 unless they are ALL identical. This is because the symbol
5069 comparison is not a strict comparison, but rather a practical
5070 comparison. If all symbols are considered identical, then
5071 we can just go ahead and use the first one and discard the rest.
5072 But if we cannot reduce the list to a single element, we have
5073 to ask the user to disambiguate anyways. And if we have to
5074 present a multiple-choice menu, it's less confusing if the list
5075 isn't missing some choices that were identical and yet distinct. */
5076 if (symbols_are_identical_enums (*syms))
5077 syms->resize (1);
5078
5079 return syms->size ();
5080 }
5081
5082 /* Given a type that corresponds to a renaming entity, use the type name
5083 to extract the scope (package name or function name, fully qualified,
5084 and following the GNAT encoding convention) where this renaming has been
5085 defined. */
5086
5087 static std::string
5088 xget_renaming_scope (struct type *renaming_type)
5089 {
5090 /* The renaming types adhere to the following convention:
5091 <scope>__<rename>___<XR extension>.
5092 So, to extract the scope, we search for the "___XR" extension,
5093 and then backtrack until we find the first "__". */
5094
5095 const char *name = TYPE_NAME (renaming_type);
5096 const char *suffix = strstr (name, "___XR");
5097 const char *last;
5098
5099 /* Now, backtrack a bit until we find the first "__". Start looking
5100 at suffix - 3, as the <rename> part is at least one character long. */
5101
5102 for (last = suffix - 3; last > name; last--)
5103 if (last[0] == '_' && last[1] == '_')
5104 break;
5105
5106 /* Make a copy of scope and return it. */
5107 return std::string (name, last);
5108 }
5109
5110 /* Return nonzero if NAME corresponds to a package name. */
5111
5112 static int
5113 is_package_name (const char *name)
5114 {
5115 /* Here, We take advantage of the fact that no symbols are generated
5116 for packages, while symbols are generated for each function.
5117 So the condition for NAME represent a package becomes equivalent
5118 to NAME not existing in our list of symbols. There is only one
5119 small complication with library-level functions (see below). */
5120
5121 /* If it is a function that has not been defined at library level,
5122 then we should be able to look it up in the symbols. */
5123 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5124 return 0;
5125
5126 /* Library-level function names start with "_ada_". See if function
5127 "_ada_" followed by NAME can be found. */
5128
5129 /* Do a quick check that NAME does not contain "__", since library-level
5130 functions names cannot contain "__" in them. */
5131 if (strstr (name, "__") != NULL)
5132 return 0;
5133
5134 std::string fun_name = string_printf ("_ada_%s", name);
5135
5136 return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
5137 }
5138
5139 /* Return nonzero if SYM corresponds to a renaming entity that is
5140 not visible from FUNCTION_NAME. */
5141
5142 static int
5143 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5144 {
5145 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5146 return 0;
5147
5148 std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
5149
5150 /* If the rename has been defined in a package, then it is visible. */
5151 if (is_package_name (scope.c_str ()))
5152 return 0;
5153
5154 /* Check that the rename is in the current function scope by checking
5155 that its name starts with SCOPE. */
5156
5157 /* If the function name starts with "_ada_", it means that it is
5158 a library-level function. Strip this prefix before doing the
5159 comparison, as the encoding for the renaming does not contain
5160 this prefix. */
5161 if (startswith (function_name, "_ada_"))
5162 function_name += 5;
5163
5164 return !startswith (function_name, scope.c_str ());
5165 }
5166
5167 /* Remove entries from SYMS that corresponds to a renaming entity that
5168 is not visible from the function associated with CURRENT_BLOCK or
5169 that is superfluous due to the presence of more specific renaming
5170 information. Places surviving symbols in the initial entries of
5171 SYMS and returns the number of surviving symbols.
5172
5173 Rationale:
5174 First, in cases where an object renaming is implemented as a
5175 reference variable, GNAT may produce both the actual reference
5176 variable and the renaming encoding. In this case, we discard the
5177 latter.
5178
5179 Second, GNAT emits a type following a specified encoding for each renaming
5180 entity. Unfortunately, STABS currently does not support the definition
5181 of types that are local to a given lexical block, so all renamings types
5182 are emitted at library level. As a consequence, if an application
5183 contains two renaming entities using the same name, and a user tries to
5184 print the value of one of these entities, the result of the ada symbol
5185 lookup will also contain the wrong renaming type.
5186
5187 This function partially covers for this limitation by attempting to
5188 remove from the SYMS list renaming symbols that should be visible
5189 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5190 method with the current information available. The implementation
5191 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5192
5193 - When the user tries to print a rename in a function while there
5194 is another rename entity defined in a package: Normally, the
5195 rename in the function has precedence over the rename in the
5196 package, so the latter should be removed from the list. This is
5197 currently not the case.
5198
5199 - This function will incorrectly remove valid renames if
5200 the CURRENT_BLOCK corresponds to a function which symbol name
5201 has been changed by an "Export" pragma. As a consequence,
5202 the user will be unable to print such rename entities. */
5203
5204 static int
5205 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5206 const struct block *current_block)
5207 {
5208 struct symbol *current_function;
5209 const char *current_function_name;
5210 int i;
5211 int is_new_style_renaming;
5212
5213 /* If there is both a renaming foo___XR... encoded as a variable and
5214 a simple variable foo in the same block, discard the latter.
5215 First, zero out such symbols, then compress. */
5216 is_new_style_renaming = 0;
5217 for (i = 0; i < syms->size (); i += 1)
5218 {
5219 struct symbol *sym = (*syms)[i].symbol;
5220 const struct block *block = (*syms)[i].block;
5221 const char *name;
5222 const char *suffix;
5223
5224 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5225 continue;
5226 name = SYMBOL_LINKAGE_NAME (sym);
5227 suffix = strstr (name, "___XR");
5228
5229 if (suffix != NULL)
5230 {
5231 int name_len = suffix - name;
5232 int j;
5233
5234 is_new_style_renaming = 1;
5235 for (j = 0; j < syms->size (); j += 1)
5236 if (i != j && (*syms)[j].symbol != NULL
5237 && strncmp (name, SYMBOL_LINKAGE_NAME ((*syms)[j].symbol),
5238 name_len) == 0
5239 && block == (*syms)[j].block)
5240 (*syms)[j].symbol = NULL;
5241 }
5242 }
5243 if (is_new_style_renaming)
5244 {
5245 int j, k;
5246
5247 for (j = k = 0; j < syms->size (); j += 1)
5248 if ((*syms)[j].symbol != NULL)
5249 {
5250 (*syms)[k] = (*syms)[j];
5251 k += 1;
5252 }
5253 return k;
5254 }
5255
5256 /* Extract the function name associated to CURRENT_BLOCK.
5257 Abort if unable to do so. */
5258
5259 if (current_block == NULL)
5260 return syms->size ();
5261
5262 current_function = block_linkage_function (current_block);
5263 if (current_function == NULL)
5264 return syms->size ();
5265
5266 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5267 if (current_function_name == NULL)
5268 return syms->size ();
5269
5270 /* Check each of the symbols, and remove it from the list if it is
5271 a type corresponding to a renaming that is out of the scope of
5272 the current block. */
5273
5274 i = 0;
5275 while (i < syms->size ())
5276 {
5277 if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
5278 == ADA_OBJECT_RENAMING
5279 && old_renaming_is_invisible ((*syms)[i].symbol,
5280 current_function_name))
5281 syms->erase (syms->begin () + i);
5282 else
5283 i += 1;
5284 }
5285
5286 return syms->size ();
5287 }
5288
5289 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5290 whose name and domain match NAME and DOMAIN respectively.
5291 If no match was found, then extend the search to "enclosing"
5292 routines (in other words, if we're inside a nested function,
5293 search the symbols defined inside the enclosing functions).
5294 If WILD_MATCH_P is nonzero, perform the naming matching in
5295 "wild" mode (see function "wild_match" for more info).
5296
5297 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5298
5299 static void
5300 ada_add_local_symbols (struct obstack *obstackp,
5301 const lookup_name_info &lookup_name,
5302 const struct block *block, domain_enum domain)
5303 {
5304 int block_depth = 0;
5305
5306 while (block != NULL)
5307 {
5308 block_depth += 1;
5309 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5310
5311 /* If we found a non-function match, assume that's the one. */
5312 if (is_nonfunction (defns_collected (obstackp, 0),
5313 num_defns_collected (obstackp)))
5314 return;
5315
5316 block = BLOCK_SUPERBLOCK (block);
5317 }
5318
5319 /* If no luck so far, try to find NAME as a local symbol in some lexically
5320 enclosing subprogram. */
5321 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
5322 add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
5323 }
5324
5325 /* An object of this type is used as the user_data argument when
5326 calling the map_matching_symbols method. */
5327
5328 struct match_data
5329 {
5330 struct objfile *objfile;
5331 struct obstack *obstackp;
5332 struct symbol *arg_sym;
5333 int found_sym;
5334 };
5335
5336 /* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
5337 to a list of symbols. DATA0 is a pointer to a struct match_data *
5338 containing the obstack that collects the symbol list, the file that SYM
5339 must come from, a flag indicating whether a non-argument symbol has
5340 been found in the current block, and the last argument symbol
5341 passed in SYM within the current block (if any). When SYM is null,
5342 marking the end of a block, the argument symbol is added if no
5343 other has been found. */
5344
5345 static int
5346 aux_add_nonlocal_symbols (const struct block *block, struct symbol *sym,
5347 void *data0)
5348 {
5349 struct match_data *data = (struct match_data *) data0;
5350
5351 if (sym == NULL)
5352 {
5353 if (!data->found_sym && data->arg_sym != NULL)
5354 add_defn_to_vec (data->obstackp,
5355 fixup_symbol_section (data->arg_sym, data->objfile),
5356 block);
5357 data->found_sym = 0;
5358 data->arg_sym = NULL;
5359 }
5360 else
5361 {
5362 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5363 return 0;
5364 else if (SYMBOL_IS_ARGUMENT (sym))
5365 data->arg_sym = sym;
5366 else
5367 {
5368 data->found_sym = 1;
5369 add_defn_to_vec (data->obstackp,
5370 fixup_symbol_section (sym, data->objfile),
5371 block);
5372 }
5373 }
5374 return 0;
5375 }
5376
5377 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5378 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5379 symbols to OBSTACKP. Return whether we found such symbols. */
5380
5381 static int
5382 ada_add_block_renamings (struct obstack *obstackp,
5383 const struct block *block,
5384 const lookup_name_info &lookup_name,
5385 domain_enum domain)
5386 {
5387 struct using_direct *renaming;
5388 int defns_mark = num_defns_collected (obstackp);
5389
5390 symbol_name_matcher_ftype *name_match
5391 = ada_get_symbol_name_matcher (lookup_name);
5392
5393 for (renaming = block_using (block);
5394 renaming != NULL;
5395 renaming = renaming->next)
5396 {
5397 const char *r_name;
5398
5399 /* Avoid infinite recursions: skip this renaming if we are actually
5400 already traversing it.
5401
5402 Currently, symbol lookup in Ada don't use the namespace machinery from
5403 C++/Fortran support: skip namespace imports that use them. */
5404 if (renaming->searched
5405 || (renaming->import_src != NULL
5406 && renaming->import_src[0] != '\0')
5407 || (renaming->import_dest != NULL
5408 && renaming->import_dest[0] != '\0'))
5409 continue;
5410 renaming->searched = 1;
5411
5412 /* TODO: here, we perform another name-based symbol lookup, which can
5413 pull its own multiple overloads. In theory, we should be able to do
5414 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5415 not a simple name. But in order to do this, we would need to enhance
5416 the DWARF reader to associate a symbol to this renaming, instead of a
5417 name. So, for now, we do something simpler: re-use the C++/Fortran
5418 namespace machinery. */
5419 r_name = (renaming->alias != NULL
5420 ? renaming->alias
5421 : renaming->declaration);
5422 if (name_match (r_name, lookup_name, NULL))
5423 {
5424 lookup_name_info decl_lookup_name (renaming->declaration,
5425 lookup_name.match_type ());
5426 ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5427 1, NULL);
5428 }
5429 renaming->searched = 0;
5430 }
5431 return num_defns_collected (obstackp) != defns_mark;
5432 }
5433
5434 /* Implements compare_names, but only applying the comparision using
5435 the given CASING. */
5436
5437 static int
5438 compare_names_with_case (const char *string1, const char *string2,
5439 enum case_sensitivity casing)
5440 {
5441 while (*string1 != '\0' && *string2 != '\0')
5442 {
5443 char c1, c2;
5444
5445 if (isspace (*string1) || isspace (*string2))
5446 return strcmp_iw_ordered (string1, string2);
5447
5448 if (casing == case_sensitive_off)
5449 {
5450 c1 = tolower (*string1);
5451 c2 = tolower (*string2);
5452 }
5453 else
5454 {
5455 c1 = *string1;
5456 c2 = *string2;
5457 }
5458 if (c1 != c2)
5459 break;
5460
5461 string1 += 1;
5462 string2 += 1;
5463 }
5464
5465 switch (*string1)
5466 {
5467 case '(':
5468 return strcmp_iw_ordered (string1, string2);
5469 case '_':
5470 if (*string2 == '\0')
5471 {
5472 if (is_name_suffix (string1))
5473 return 0;
5474 else
5475 return 1;
5476 }
5477 /* FALLTHROUGH */
5478 default:
5479 if (*string2 == '(')
5480 return strcmp_iw_ordered (string1, string2);
5481 else
5482 {
5483 if (casing == case_sensitive_off)
5484 return tolower (*string1) - tolower (*string2);
5485 else
5486 return *string1 - *string2;
5487 }
5488 }
5489 }
5490
5491 /* Compare STRING1 to STRING2, with results as for strcmp.
5492 Compatible with strcmp_iw_ordered in that...
5493
5494 strcmp_iw_ordered (STRING1, STRING2) <= 0
5495
5496 ... implies...
5497
5498 compare_names (STRING1, STRING2) <= 0
5499
5500 (they may differ as to what symbols compare equal). */
5501
5502 static int
5503 compare_names (const char *string1, const char *string2)
5504 {
5505 int result;
5506
5507 /* Similar to what strcmp_iw_ordered does, we need to perform
5508 a case-insensitive comparison first, and only resort to
5509 a second, case-sensitive, comparison if the first one was
5510 not sufficient to differentiate the two strings. */
5511
5512 result = compare_names_with_case (string1, string2, case_sensitive_off);
5513 if (result == 0)
5514 result = compare_names_with_case (string1, string2, case_sensitive_on);
5515
5516 return result;
5517 }
5518
5519 /* Convenience function to get at the Ada encoded lookup name for
5520 LOOKUP_NAME, as a C string. */
5521
5522 static const char *
5523 ada_lookup_name (const lookup_name_info &lookup_name)
5524 {
5525 return lookup_name.ada ().lookup_name ().c_str ();
5526 }
5527
5528 /* Add to OBSTACKP all non-local symbols whose name and domain match
5529 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5530 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5531 symbols otherwise. */
5532
5533 static void
5534 add_nonlocal_symbols (struct obstack *obstackp,
5535 const lookup_name_info &lookup_name,
5536 domain_enum domain, int global)
5537 {
5538 struct match_data data;
5539
5540 memset (&data, 0, sizeof data);
5541 data.obstackp = obstackp;
5542
5543 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5544
5545 for (objfile *objfile : current_program_space->objfiles ())
5546 {
5547 data.objfile = objfile;
5548
5549 if (is_wild_match)
5550 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5551 domain, global,
5552 aux_add_nonlocal_symbols, &data,
5553 symbol_name_match_type::WILD,
5554 NULL);
5555 else
5556 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5557 domain, global,
5558 aux_add_nonlocal_symbols, &data,
5559 symbol_name_match_type::FULL,
5560 compare_names);
5561
5562 for (compunit_symtab *cu : objfile->compunits ())
5563 {
5564 const struct block *global_block
5565 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5566
5567 if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5568 domain))
5569 data.found_sym = 1;
5570 }
5571 }
5572
5573 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5574 {
5575 const char *name = ada_lookup_name (lookup_name);
5576 std::string name1 = std::string ("<_ada_") + name + '>';
5577
5578 for (objfile *objfile : current_program_space->objfiles ())
5579 {
5580 data.objfile = objfile;
5581 objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (),
5582 domain, global,
5583 aux_add_nonlocal_symbols,
5584 &data,
5585 symbol_name_match_type::FULL,
5586 compare_names);
5587 }
5588 }
5589 }
5590
5591 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5592 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5593 returning the number of matches. Add these to OBSTACKP.
5594
5595 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5596 symbol match within the nest of blocks whose innermost member is BLOCK,
5597 is the one match returned (no other matches in that or
5598 enclosing blocks is returned). If there are any matches in or
5599 surrounding BLOCK, then these alone are returned.
5600
5601 Names prefixed with "standard__" are handled specially:
5602 "standard__" is first stripped off (by the lookup_name
5603 constructor), and only static and global symbols are searched.
5604
5605 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5606 to lookup global symbols. */
5607
5608 static void
5609 ada_add_all_symbols (struct obstack *obstackp,
5610 const struct block *block,
5611 const lookup_name_info &lookup_name,
5612 domain_enum domain,
5613 int full_search,
5614 int *made_global_lookup_p)
5615 {
5616 struct symbol *sym;
5617
5618 if (made_global_lookup_p)
5619 *made_global_lookup_p = 0;
5620
5621 /* Special case: If the user specifies a symbol name inside package
5622 Standard, do a non-wild matching of the symbol name without
5623 the "standard__" prefix. This was primarily introduced in order
5624 to allow the user to specifically access the standard exceptions
5625 using, for instance, Standard.Constraint_Error when Constraint_Error
5626 is ambiguous (due to the user defining its own Constraint_Error
5627 entity inside its program). */
5628 if (lookup_name.ada ().standard_p ())
5629 block = NULL;
5630
5631 /* Check the non-global symbols. If we have ANY match, then we're done. */
5632
5633 if (block != NULL)
5634 {
5635 if (full_search)
5636 ada_add_local_symbols (obstackp, lookup_name, block, domain);
5637 else
5638 {
5639 /* In the !full_search case we're are being called by
5640 ada_iterate_over_symbols, and we don't want to search
5641 superblocks. */
5642 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5643 }
5644 if (num_defns_collected (obstackp) > 0 || !full_search)
5645 return;
5646 }
5647
5648 /* No non-global symbols found. Check our cache to see if we have
5649 already performed this search before. If we have, then return
5650 the same result. */
5651
5652 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5653 domain, &sym, &block))
5654 {
5655 if (sym != NULL)
5656 add_defn_to_vec (obstackp, sym, block);
5657 return;
5658 }
5659
5660 if (made_global_lookup_p)
5661 *made_global_lookup_p = 1;
5662
5663 /* Search symbols from all global blocks. */
5664
5665 add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
5666
5667 /* Now add symbols from all per-file blocks if we've gotten no hits
5668 (not strictly correct, but perhaps better than an error). */
5669
5670 if (num_defns_collected (obstackp) == 0)
5671 add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
5672 }
5673
5674 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5675 is non-zero, enclosing scope and in global scopes, returning the number of
5676 matches.
5677 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5678 found and the blocks and symbol tables (if any) in which they were
5679 found.
5680
5681 When full_search is non-zero, any non-function/non-enumeral
5682 symbol match within the nest of blocks whose innermost member is BLOCK,
5683 is the one match returned (no other matches in that or
5684 enclosing blocks is returned). If there are any matches in or
5685 surrounding BLOCK, then these alone are returned.
5686
5687 Names prefixed with "standard__" are handled specially: "standard__"
5688 is first stripped off, and only static and global symbols are searched. */
5689
5690 static int
5691 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5692 const struct block *block,
5693 domain_enum domain,
5694 std::vector<struct block_symbol> *results,
5695 int full_search)
5696 {
5697 int syms_from_global_search;
5698 int ndefns;
5699 auto_obstack obstack;
5700
5701 ada_add_all_symbols (&obstack, block, lookup_name,
5702 domain, full_search, &syms_from_global_search);
5703
5704 ndefns = num_defns_collected (&obstack);
5705
5706 struct block_symbol *base = defns_collected (&obstack, 1);
5707 for (int i = 0; i < ndefns; ++i)
5708 results->push_back (base[i]);
5709
5710 ndefns = remove_extra_symbols (results);
5711
5712 if (ndefns == 0 && full_search && syms_from_global_search)
5713 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5714
5715 if (ndefns == 1 && full_search && syms_from_global_search)
5716 cache_symbol (ada_lookup_name (lookup_name), domain,
5717 (*results)[0].symbol, (*results)[0].block);
5718
5719 ndefns = remove_irrelevant_renamings (results, block);
5720
5721 return ndefns;
5722 }
5723
5724 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5725 in global scopes, returning the number of matches, and filling *RESULTS
5726 with (SYM,BLOCK) tuples.
5727
5728 See ada_lookup_symbol_list_worker for further details. */
5729
5730 int
5731 ada_lookup_symbol_list (const char *name, const struct block *block,
5732 domain_enum domain,
5733 std::vector<struct block_symbol> *results)
5734 {
5735 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5736 lookup_name_info lookup_name (name, name_match_type);
5737
5738 return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
5739 }
5740
5741 /* Implementation of the la_iterate_over_symbols method. */
5742
5743 static void
5744 ada_iterate_over_symbols
5745 (const struct block *block, const lookup_name_info &name,
5746 domain_enum domain,
5747 gdb::function_view<symbol_found_callback_ftype> callback)
5748 {
5749 int ndefs, i;
5750 std::vector<struct block_symbol> results;
5751
5752 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5753
5754 for (i = 0; i < ndefs; ++i)
5755 {
5756 if (!callback (&results[i]))
5757 break;
5758 }
5759 }
5760
5761 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5762 to 1, but choosing the first symbol found if there are multiple
5763 choices.
5764
5765 The result is stored in *INFO, which must be non-NULL.
5766 If no match is found, INFO->SYM is set to NULL. */
5767
5768 void
5769 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5770 domain_enum domain,
5771 struct block_symbol *info)
5772 {
5773 /* Since we already have an encoded name, wrap it in '<>' to force a
5774 verbatim match. Otherwise, if the name happens to not look like
5775 an encoded name (because it doesn't include a "__"),
5776 ada_lookup_name_info would re-encode/fold it again, and that
5777 would e.g., incorrectly lowercase object renaming names like
5778 "R28b" -> "r28b". */
5779 std::string verbatim = std::string ("<") + name + '>';
5780
5781 gdb_assert (info != NULL);
5782 *info = ada_lookup_symbol (verbatim.c_str (), block, domain, NULL);
5783 }
5784
5785 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5786 scope and in global scopes, or NULL if none. NAME is folded and
5787 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5788 choosing the first symbol if there are multiple choices.
5789 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5790
5791 struct block_symbol
5792 ada_lookup_symbol (const char *name, const struct block *block0,
5793 domain_enum domain, int *is_a_field_of_this)
5794 {
5795 if (is_a_field_of_this != NULL)
5796 *is_a_field_of_this = 0;
5797
5798 std::vector<struct block_symbol> candidates;
5799 int n_candidates;
5800
5801 n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates);
5802
5803 if (n_candidates == 0)
5804 return {};
5805
5806 block_symbol info = candidates[0];
5807 info.symbol = fixup_symbol_section (info.symbol, NULL);
5808 return info;
5809 }
5810
5811 static struct block_symbol
5812 ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5813 const char *name,
5814 const struct block *block,
5815 const domain_enum domain)
5816 {
5817 struct block_symbol sym;
5818
5819 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
5820 if (sym.symbol != NULL)
5821 return sym;
5822
5823 /* If we haven't found a match at this point, try the primitive
5824 types. In other languages, this search is performed before
5825 searching for global symbols in order to short-circuit that
5826 global-symbol search if it happens that the name corresponds
5827 to a primitive type. But we cannot do the same in Ada, because
5828 it is perfectly legitimate for a program to declare a type which
5829 has the same name as a standard type. If looking up a type in
5830 that situation, we have traditionally ignored the primitive type
5831 in favor of user-defined types. This is why, unlike most other
5832 languages, we search the primitive types this late and only after
5833 having searched the global symbols without success. */
5834
5835 if (domain == VAR_DOMAIN)
5836 {
5837 struct gdbarch *gdbarch;
5838
5839 if (block == NULL)
5840 gdbarch = target_gdbarch ();
5841 else
5842 gdbarch = block_gdbarch (block);
5843 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5844 if (sym.symbol != NULL)
5845 return sym;
5846 }
5847
5848 return {};
5849 }
5850
5851
5852 /* True iff STR is a possible encoded suffix of a normal Ada name
5853 that is to be ignored for matching purposes. Suffixes of parallel
5854 names (e.g., XVE) are not included here. Currently, the possible suffixes
5855 are given by any of the regular expressions:
5856
5857 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5858 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5859 TKB [subprogram suffix for task bodies]
5860 _E[0-9]+[bs]$ [protected object entry suffixes]
5861 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5862
5863 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5864 match is performed. This sequence is used to differentiate homonyms,
5865 is an optional part of a valid name suffix. */
5866
5867 static int
5868 is_name_suffix (const char *str)
5869 {
5870 int k;
5871 const char *matching;
5872 const int len = strlen (str);
5873
5874 /* Skip optional leading __[0-9]+. */
5875
5876 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5877 {
5878 str += 3;
5879 while (isdigit (str[0]))
5880 str += 1;
5881 }
5882
5883 /* [.$][0-9]+ */
5884
5885 if (str[0] == '.' || str[0] == '$')
5886 {
5887 matching = str + 1;
5888 while (isdigit (matching[0]))
5889 matching += 1;
5890 if (matching[0] == '\0')
5891 return 1;
5892 }
5893
5894 /* ___[0-9]+ */
5895
5896 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5897 {
5898 matching = str + 3;
5899 while (isdigit (matching[0]))
5900 matching += 1;
5901 if (matching[0] == '\0')
5902 return 1;
5903 }
5904
5905 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5906
5907 if (strcmp (str, "TKB") == 0)
5908 return 1;
5909
5910 #if 0
5911 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5912 with a N at the end. Unfortunately, the compiler uses the same
5913 convention for other internal types it creates. So treating
5914 all entity names that end with an "N" as a name suffix causes
5915 some regressions. For instance, consider the case of an enumerated
5916 type. To support the 'Image attribute, it creates an array whose
5917 name ends with N.
5918 Having a single character like this as a suffix carrying some
5919 information is a bit risky. Perhaps we should change the encoding
5920 to be something like "_N" instead. In the meantime, do not do
5921 the following check. */
5922 /* Protected Object Subprograms */
5923 if (len == 1 && str [0] == 'N')
5924 return 1;
5925 #endif
5926
5927 /* _E[0-9]+[bs]$ */
5928 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5929 {
5930 matching = str + 3;
5931 while (isdigit (matching[0]))
5932 matching += 1;
5933 if ((matching[0] == 'b' || matching[0] == 's')
5934 && matching [1] == '\0')
5935 return 1;
5936 }
5937
5938 /* ??? We should not modify STR directly, as we are doing below. This
5939 is fine in this case, but may become problematic later if we find
5940 that this alternative did not work, and want to try matching
5941 another one from the begining of STR. Since we modified it, we
5942 won't be able to find the begining of the string anymore! */
5943 if (str[0] == 'X')
5944 {
5945 str += 1;
5946 while (str[0] != '_' && str[0] != '\0')
5947 {
5948 if (str[0] != 'n' && str[0] != 'b')
5949 return 0;
5950 str += 1;
5951 }
5952 }
5953
5954 if (str[0] == '\000')
5955 return 1;
5956
5957 if (str[0] == '_')
5958 {
5959 if (str[1] != '_' || str[2] == '\000')
5960 return 0;
5961 if (str[2] == '_')
5962 {
5963 if (strcmp (str + 3, "JM") == 0)
5964 return 1;
5965 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5966 the LJM suffix in favor of the JM one. But we will
5967 still accept LJM as a valid suffix for a reasonable
5968 amount of time, just to allow ourselves to debug programs
5969 compiled using an older version of GNAT. */
5970 if (strcmp (str + 3, "LJM") == 0)
5971 return 1;
5972 if (str[3] != 'X')
5973 return 0;
5974 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5975 || str[4] == 'U' || str[4] == 'P')
5976 return 1;
5977 if (str[4] == 'R' && str[5] != 'T')
5978 return 1;
5979 return 0;
5980 }
5981 if (!isdigit (str[2]))
5982 return 0;
5983 for (k = 3; str[k] != '\0'; k += 1)
5984 if (!isdigit (str[k]) && str[k] != '_')
5985 return 0;
5986 return 1;
5987 }
5988 if (str[0] == '$' && isdigit (str[1]))
5989 {
5990 for (k = 2; str[k] != '\0'; k += 1)
5991 if (!isdigit (str[k]) && str[k] != '_')
5992 return 0;
5993 return 1;
5994 }
5995 return 0;
5996 }
5997
5998 /* Return non-zero if the string starting at NAME and ending before
5999 NAME_END contains no capital letters. */
6000
6001 static int
6002 is_valid_name_for_wild_match (const char *name0)
6003 {
6004 const char *decoded_name = ada_decode (name0);
6005 int i;
6006
6007 /* If the decoded name starts with an angle bracket, it means that
6008 NAME0 does not follow the GNAT encoding format. It should then
6009 not be allowed as a possible wild match. */
6010 if (decoded_name[0] == '<')
6011 return 0;
6012
6013 for (i=0; decoded_name[i] != '\0'; i++)
6014 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6015 return 0;
6016
6017 return 1;
6018 }
6019
6020 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6021 that could start a simple name. Assumes that *NAMEP points into
6022 the string beginning at NAME0. */
6023
6024 static int
6025 advance_wild_match (const char **namep, const char *name0, int target0)
6026 {
6027 const char *name = *namep;
6028
6029 while (1)
6030 {
6031 int t0, t1;
6032
6033 t0 = *name;
6034 if (t0 == '_')
6035 {
6036 t1 = name[1];
6037 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6038 {
6039 name += 1;
6040 if (name == name0 + 5 && startswith (name0, "_ada"))
6041 break;
6042 else
6043 name += 1;
6044 }
6045 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6046 || name[2] == target0))
6047 {
6048 name += 2;
6049 break;
6050 }
6051 else
6052 return 0;
6053 }
6054 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6055 name += 1;
6056 else
6057 return 0;
6058 }
6059
6060 *namep = name;
6061 return 1;
6062 }
6063
6064 /* Return true iff NAME encodes a name of the form prefix.PATN.
6065 Ignores any informational suffixes of NAME (i.e., for which
6066 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6067 simple name. */
6068
6069 static bool
6070 wild_match (const char *name, const char *patn)
6071 {
6072 const char *p;
6073 const char *name0 = name;
6074
6075 while (1)
6076 {
6077 const char *match = name;
6078
6079 if (*name == *patn)
6080 {
6081 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6082 if (*p != *name)
6083 break;
6084 if (*p == '\0' && is_name_suffix (name))
6085 return match == name0 || is_valid_name_for_wild_match (name0);
6086
6087 if (name[-1] == '_')
6088 name -= 1;
6089 }
6090 if (!advance_wild_match (&name, name0, *patn))
6091 return false;
6092 }
6093 }
6094
6095 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6096 any trailing suffixes that encode debugging information or leading
6097 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6098 information that is ignored). */
6099
6100 static bool
6101 full_match (const char *sym_name, const char *search_name)
6102 {
6103 size_t search_name_len = strlen (search_name);
6104
6105 if (strncmp (sym_name, search_name, search_name_len) == 0
6106 && is_name_suffix (sym_name + search_name_len))
6107 return true;
6108
6109 if (startswith (sym_name, "_ada_")
6110 && strncmp (sym_name + 5, search_name, search_name_len) == 0
6111 && is_name_suffix (sym_name + search_name_len + 5))
6112 return true;
6113
6114 return false;
6115 }
6116
6117 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6118 *defn_symbols, updating the list of symbols in OBSTACKP (if
6119 necessary). OBJFILE is the section containing BLOCK. */
6120
6121 static void
6122 ada_add_block_symbols (struct obstack *obstackp,
6123 const struct block *block,
6124 const lookup_name_info &lookup_name,
6125 domain_enum domain, struct objfile *objfile)
6126 {
6127 struct block_iterator iter;
6128 /* A matching argument symbol, if any. */
6129 struct symbol *arg_sym;
6130 /* Set true when we find a matching non-argument symbol. */
6131 int found_sym;
6132 struct symbol *sym;
6133
6134 arg_sym = NULL;
6135 found_sym = 0;
6136 for (sym = block_iter_match_first (block, lookup_name, &iter);
6137 sym != NULL;
6138 sym = block_iter_match_next (lookup_name, &iter))
6139 {
6140 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6141 SYMBOL_DOMAIN (sym), domain))
6142 {
6143 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6144 {
6145 if (SYMBOL_IS_ARGUMENT (sym))
6146 arg_sym = sym;
6147 else
6148 {
6149 found_sym = 1;
6150 add_defn_to_vec (obstackp,
6151 fixup_symbol_section (sym, objfile),
6152 block);
6153 }
6154 }
6155 }
6156 }
6157
6158 /* Handle renamings. */
6159
6160 if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
6161 found_sym = 1;
6162
6163 if (!found_sym && arg_sym != NULL)
6164 {
6165 add_defn_to_vec (obstackp,
6166 fixup_symbol_section (arg_sym, objfile),
6167 block);
6168 }
6169
6170 if (!lookup_name.ada ().wild_match_p ())
6171 {
6172 arg_sym = NULL;
6173 found_sym = 0;
6174 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6175 const char *name = ada_lookup_name.c_str ();
6176 size_t name_len = ada_lookup_name.size ();
6177
6178 ALL_BLOCK_SYMBOLS (block, iter, sym)
6179 {
6180 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6181 SYMBOL_DOMAIN (sym), domain))
6182 {
6183 int cmp;
6184
6185 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6186 if (cmp == 0)
6187 {
6188 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
6189 if (cmp == 0)
6190 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6191 name_len);
6192 }
6193
6194 if (cmp == 0
6195 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6196 {
6197 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6198 {
6199 if (SYMBOL_IS_ARGUMENT (sym))
6200 arg_sym = sym;
6201 else
6202 {
6203 found_sym = 1;
6204 add_defn_to_vec (obstackp,
6205 fixup_symbol_section (sym, objfile),
6206 block);
6207 }
6208 }
6209 }
6210 }
6211 }
6212
6213 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6214 They aren't parameters, right? */
6215 if (!found_sym && arg_sym != NULL)
6216 {
6217 add_defn_to_vec (obstackp,
6218 fixup_symbol_section (arg_sym, objfile),
6219 block);
6220 }
6221 }
6222 }
6223 \f
6224
6225 /* Symbol Completion */
6226
6227 /* See symtab.h. */
6228
6229 bool
6230 ada_lookup_name_info::matches
6231 (const char *sym_name,
6232 symbol_name_match_type match_type,
6233 completion_match_result *comp_match_res) const
6234 {
6235 bool match = false;
6236 const char *text = m_encoded_name.c_str ();
6237 size_t text_len = m_encoded_name.size ();
6238
6239 /* First, test against the fully qualified name of the symbol. */
6240
6241 if (strncmp (sym_name, text, text_len) == 0)
6242 match = true;
6243
6244 if (match && !m_encoded_p)
6245 {
6246 /* One needed check before declaring a positive match is to verify
6247 that iff we are doing a verbatim match, the decoded version
6248 of the symbol name starts with '<'. Otherwise, this symbol name
6249 is not a suitable completion. */
6250 const char *sym_name_copy = sym_name;
6251 bool has_angle_bracket;
6252
6253 sym_name = ada_decode (sym_name);
6254 has_angle_bracket = (sym_name[0] == '<');
6255 match = (has_angle_bracket == m_verbatim_p);
6256 sym_name = sym_name_copy;
6257 }
6258
6259 if (match && !m_verbatim_p)
6260 {
6261 /* When doing non-verbatim match, another check that needs to
6262 be done is to verify that the potentially matching symbol name
6263 does not include capital letters, because the ada-mode would
6264 not be able to understand these symbol names without the
6265 angle bracket notation. */
6266 const char *tmp;
6267
6268 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6269 if (*tmp != '\0')
6270 match = false;
6271 }
6272
6273 /* Second: Try wild matching... */
6274
6275 if (!match && m_wild_match_p)
6276 {
6277 /* Since we are doing wild matching, this means that TEXT
6278 may represent an unqualified symbol name. We therefore must
6279 also compare TEXT against the unqualified name of the symbol. */
6280 sym_name = ada_unqualified_name (ada_decode (sym_name));
6281
6282 if (strncmp (sym_name, text, text_len) == 0)
6283 match = true;
6284 }
6285
6286 /* Finally: If we found a match, prepare the result to return. */
6287
6288 if (!match)
6289 return false;
6290
6291 if (comp_match_res != NULL)
6292 {
6293 std::string &match_str = comp_match_res->match.storage ();
6294
6295 if (!m_encoded_p)
6296 match_str = ada_decode (sym_name);
6297 else
6298 {
6299 if (m_verbatim_p)
6300 match_str = add_angle_brackets (sym_name);
6301 else
6302 match_str = sym_name;
6303
6304 }
6305
6306 comp_match_res->set_match (match_str.c_str ());
6307 }
6308
6309 return true;
6310 }
6311
6312 /* Add the list of possible symbol names completing TEXT to TRACKER.
6313 WORD is the entire command on which completion is made. */
6314
6315 static void
6316 ada_collect_symbol_completion_matches (completion_tracker &tracker,
6317 complete_symbol_mode mode,
6318 symbol_name_match_type name_match_type,
6319 const char *text, const char *word,
6320 enum type_code code)
6321 {
6322 struct symbol *sym;
6323 const struct block *b, *surrounding_static_block = 0;
6324 struct block_iterator iter;
6325
6326 gdb_assert (code == TYPE_CODE_UNDEF);
6327
6328 lookup_name_info lookup_name (text, name_match_type, true);
6329
6330 /* First, look at the partial symtab symbols. */
6331 expand_symtabs_matching (NULL,
6332 lookup_name,
6333 NULL,
6334 NULL,
6335 ALL_DOMAIN);
6336
6337 /* At this point scan through the misc symbol vectors and add each
6338 symbol you find to the list. Eventually we want to ignore
6339 anything that isn't a text symbol (everything else will be
6340 handled by the psymtab code above). */
6341
6342 for (objfile *objfile : current_program_space->objfiles ())
6343 {
6344 for (minimal_symbol *msymbol : objfile->msymbols ())
6345 {
6346 QUIT;
6347
6348 if (completion_skip_symbol (mode, msymbol))
6349 continue;
6350
6351 language symbol_language = MSYMBOL_LANGUAGE (msymbol);
6352
6353 /* Ada minimal symbols won't have their language set to Ada. If
6354 we let completion_list_add_name compare using the
6355 default/C-like matcher, then when completing e.g., symbols in a
6356 package named "pck", we'd match internal Ada symbols like
6357 "pckS", which are invalid in an Ada expression, unless you wrap
6358 them in '<' '>' to request a verbatim match.
6359
6360 Unfortunately, some Ada encoded names successfully demangle as
6361 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6362 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6363 with the wrong language set. Paper over that issue here. */
6364 if (symbol_language == language_auto
6365 || symbol_language == language_cplus)
6366 symbol_language = language_ada;
6367
6368 completion_list_add_name (tracker,
6369 symbol_language,
6370 MSYMBOL_LINKAGE_NAME (msymbol),
6371 lookup_name, text, word);
6372 }
6373 }
6374
6375 /* Search upwards from currently selected frame (so that we can
6376 complete on local vars. */
6377
6378 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6379 {
6380 if (!BLOCK_SUPERBLOCK (b))
6381 surrounding_static_block = b; /* For elmin of dups */
6382
6383 ALL_BLOCK_SYMBOLS (b, iter, sym)
6384 {
6385 if (completion_skip_symbol (mode, sym))
6386 continue;
6387
6388 completion_list_add_name (tracker,
6389 SYMBOL_LANGUAGE (sym),
6390 SYMBOL_LINKAGE_NAME (sym),
6391 lookup_name, text, word);
6392 }
6393 }
6394
6395 /* Go through the symtabs and check the externs and statics for
6396 symbols which match. */
6397
6398 for (objfile *objfile : current_program_space->objfiles ())
6399 {
6400 for (compunit_symtab *s : objfile->compunits ())
6401 {
6402 QUIT;
6403 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
6404 ALL_BLOCK_SYMBOLS (b, iter, sym)
6405 {
6406 if (completion_skip_symbol (mode, sym))
6407 continue;
6408
6409 completion_list_add_name (tracker,
6410 SYMBOL_LANGUAGE (sym),
6411 SYMBOL_LINKAGE_NAME (sym),
6412 lookup_name, text, word);
6413 }
6414 }
6415 }
6416
6417 for (objfile *objfile : current_program_space->objfiles ())
6418 {
6419 for (compunit_symtab *s : objfile->compunits ())
6420 {
6421 QUIT;
6422 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
6423 /* Don't do this block twice. */
6424 if (b == surrounding_static_block)
6425 continue;
6426 ALL_BLOCK_SYMBOLS (b, iter, sym)
6427 {
6428 if (completion_skip_symbol (mode, sym))
6429 continue;
6430
6431 completion_list_add_name (tracker,
6432 SYMBOL_LANGUAGE (sym),
6433 SYMBOL_LINKAGE_NAME (sym),
6434 lookup_name, text, word);
6435 }
6436 }
6437 }
6438 }
6439
6440 /* Field Access */
6441
6442 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6443 for tagged types. */
6444
6445 static int
6446 ada_is_dispatch_table_ptr_type (struct type *type)
6447 {
6448 const char *name;
6449
6450 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6451 return 0;
6452
6453 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6454 if (name == NULL)
6455 return 0;
6456
6457 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6458 }
6459
6460 /* Return non-zero if TYPE is an interface tag. */
6461
6462 static int
6463 ada_is_interface_tag (struct type *type)
6464 {
6465 const char *name = TYPE_NAME (type);
6466
6467 if (name == NULL)
6468 return 0;
6469
6470 return (strcmp (name, "ada__tags__interface_tag") == 0);
6471 }
6472
6473 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6474 to be invisible to users. */
6475
6476 int
6477 ada_is_ignored_field (struct type *type, int field_num)
6478 {
6479 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6480 return 1;
6481
6482 /* Check the name of that field. */
6483 {
6484 const char *name = TYPE_FIELD_NAME (type, field_num);
6485
6486 /* Anonymous field names should not be printed.
6487 brobecker/2007-02-20: I don't think this can actually happen
6488 but we don't want to print the value of annonymous fields anyway. */
6489 if (name == NULL)
6490 return 1;
6491
6492 /* Normally, fields whose name start with an underscore ("_")
6493 are fields that have been internally generated by the compiler,
6494 and thus should not be printed. The "_parent" field is special,
6495 however: This is a field internally generated by the compiler
6496 for tagged types, and it contains the components inherited from
6497 the parent type. This field should not be printed as is, but
6498 should not be ignored either. */
6499 if (name[0] == '_' && !startswith (name, "_parent"))
6500 return 1;
6501 }
6502
6503 /* If this is the dispatch table of a tagged type or an interface tag,
6504 then ignore. */
6505 if (ada_is_tagged_type (type, 1)
6506 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6507 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
6508 return 1;
6509
6510 /* Not a special field, so it should not be ignored. */
6511 return 0;
6512 }
6513
6514 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6515 pointer or reference type whose ultimate target has a tag field. */
6516
6517 int
6518 ada_is_tagged_type (struct type *type, int refok)
6519 {
6520 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6521 }
6522
6523 /* True iff TYPE represents the type of X'Tag */
6524
6525 int
6526 ada_is_tag_type (struct type *type)
6527 {
6528 type = ada_check_typedef (type);
6529
6530 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6531 return 0;
6532 else
6533 {
6534 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6535
6536 return (name != NULL
6537 && strcmp (name, "ada__tags__dispatch_table") == 0);
6538 }
6539 }
6540
6541 /* The type of the tag on VAL. */
6542
6543 struct type *
6544 ada_tag_type (struct value *val)
6545 {
6546 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6547 }
6548
6549 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6550 retired at Ada 05). */
6551
6552 static int
6553 is_ada95_tag (struct value *tag)
6554 {
6555 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6556 }
6557
6558 /* The value of the tag on VAL. */
6559
6560 struct value *
6561 ada_value_tag (struct value *val)
6562 {
6563 return ada_value_struct_elt (val, "_tag", 0);
6564 }
6565
6566 /* The value of the tag on the object of type TYPE whose contents are
6567 saved at VALADDR, if it is non-null, or is at memory address
6568 ADDRESS. */
6569
6570 static struct value *
6571 value_tag_from_contents_and_address (struct type *type,
6572 const gdb_byte *valaddr,
6573 CORE_ADDR address)
6574 {
6575 int tag_byte_offset;
6576 struct type *tag_type;
6577
6578 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
6579 NULL, NULL, NULL))
6580 {
6581 const gdb_byte *valaddr1 = ((valaddr == NULL)
6582 ? NULL
6583 : valaddr + tag_byte_offset);
6584 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6585
6586 return value_from_contents_and_address (tag_type, valaddr1, address1);
6587 }
6588 return NULL;
6589 }
6590
6591 static struct type *
6592 type_from_tag (struct value *tag)
6593 {
6594 const char *type_name = ada_tag_name (tag);
6595
6596 if (type_name != NULL)
6597 return ada_find_any_type (ada_encode (type_name));
6598 return NULL;
6599 }
6600
6601 /* Given a value OBJ of a tagged type, return a value of this
6602 type at the base address of the object. The base address, as
6603 defined in Ada.Tags, it is the address of the primary tag of
6604 the object, and therefore where the field values of its full
6605 view can be fetched. */
6606
6607 struct value *
6608 ada_tag_value_at_base_address (struct value *obj)
6609 {
6610 struct value *val;
6611 LONGEST offset_to_top = 0;
6612 struct type *ptr_type, *obj_type;
6613 struct value *tag;
6614 CORE_ADDR base_address;
6615
6616 obj_type = value_type (obj);
6617
6618 /* It is the responsability of the caller to deref pointers. */
6619
6620 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6621 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6622 return obj;
6623
6624 tag = ada_value_tag (obj);
6625 if (!tag)
6626 return obj;
6627
6628 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6629
6630 if (is_ada95_tag (tag))
6631 return obj;
6632
6633 ptr_type = language_lookup_primitive_type
6634 (language_def (language_ada), target_gdbarch(), "storage_offset");
6635 ptr_type = lookup_pointer_type (ptr_type);
6636 val = value_cast (ptr_type, tag);
6637 if (!val)
6638 return obj;
6639
6640 /* It is perfectly possible that an exception be raised while
6641 trying to determine the base address, just like for the tag;
6642 see ada_tag_name for more details. We do not print the error
6643 message for the same reason. */
6644
6645 try
6646 {
6647 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6648 }
6649
6650 catch (const gdb_exception_error &e)
6651 {
6652 return obj;
6653 }
6654
6655 /* If offset is null, nothing to do. */
6656
6657 if (offset_to_top == 0)
6658 return obj;
6659
6660 /* -1 is a special case in Ada.Tags; however, what should be done
6661 is not quite clear from the documentation. So do nothing for
6662 now. */
6663
6664 if (offset_to_top == -1)
6665 return obj;
6666
6667 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6668 from the base address. This was however incompatible with
6669 C++ dispatch table: C++ uses a *negative* value to *add*
6670 to the base address. Ada's convention has therefore been
6671 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6672 use the same convention. Here, we support both cases by
6673 checking the sign of OFFSET_TO_TOP. */
6674
6675 if (offset_to_top > 0)
6676 offset_to_top = -offset_to_top;
6677
6678 base_address = value_address (obj) + offset_to_top;
6679 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6680
6681 /* Make sure that we have a proper tag at the new address.
6682 Otherwise, offset_to_top is bogus (which can happen when
6683 the object is not initialized yet). */
6684
6685 if (!tag)
6686 return obj;
6687
6688 obj_type = type_from_tag (tag);
6689
6690 if (!obj_type)
6691 return obj;
6692
6693 return value_from_contents_and_address (obj_type, NULL, base_address);
6694 }
6695
6696 /* Return the "ada__tags__type_specific_data" type. */
6697
6698 static struct type *
6699 ada_get_tsd_type (struct inferior *inf)
6700 {
6701 struct ada_inferior_data *data = get_ada_inferior_data (inf);
6702
6703 if (data->tsd_type == 0)
6704 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6705 return data->tsd_type;
6706 }
6707
6708 /* Return the TSD (type-specific data) associated to the given TAG.
6709 TAG is assumed to be the tag of a tagged-type entity.
6710
6711 May return NULL if we are unable to get the TSD. */
6712
6713 static struct value *
6714 ada_get_tsd_from_tag (struct value *tag)
6715 {
6716 struct value *val;
6717 struct type *type;
6718
6719 /* First option: The TSD is simply stored as a field of our TAG.
6720 Only older versions of GNAT would use this format, but we have
6721 to test it first, because there are no visible markers for
6722 the current approach except the absence of that field. */
6723
6724 val = ada_value_struct_elt (tag, "tsd", 1);
6725 if (val)
6726 return val;
6727
6728 /* Try the second representation for the dispatch table (in which
6729 there is no explicit 'tsd' field in the referent of the tag pointer,
6730 and instead the tsd pointer is stored just before the dispatch
6731 table. */
6732
6733 type = ada_get_tsd_type (current_inferior());
6734 if (type == NULL)
6735 return NULL;
6736 type = lookup_pointer_type (lookup_pointer_type (type));
6737 val = value_cast (type, tag);
6738 if (val == NULL)
6739 return NULL;
6740 return value_ind (value_ptradd (val, -1));
6741 }
6742
6743 /* Given the TSD of a tag (type-specific data), return a string
6744 containing the name of the associated type.
6745
6746 The returned value is good until the next call. May return NULL
6747 if we are unable to determine the tag name. */
6748
6749 static char *
6750 ada_tag_name_from_tsd (struct value *tsd)
6751 {
6752 static char name[1024];
6753 char *p;
6754 struct value *val;
6755
6756 val = ada_value_struct_elt (tsd, "expanded_name", 1);
6757 if (val == NULL)
6758 return NULL;
6759 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6760 for (p = name; *p != '\0'; p += 1)
6761 if (isalpha (*p))
6762 *p = tolower (*p);
6763 return name;
6764 }
6765
6766 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6767 a C string.
6768
6769 Return NULL if the TAG is not an Ada tag, or if we were unable to
6770 determine the name of that tag. The result is good until the next
6771 call. */
6772
6773 const char *
6774 ada_tag_name (struct value *tag)
6775 {
6776 char *name = NULL;
6777
6778 if (!ada_is_tag_type (value_type (tag)))
6779 return NULL;
6780
6781 /* It is perfectly possible that an exception be raised while trying
6782 to determine the TAG's name, even under normal circumstances:
6783 The associated variable may be uninitialized or corrupted, for
6784 instance. We do not let any exception propagate past this point.
6785 instead we return NULL.
6786
6787 We also do not print the error message either (which often is very
6788 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6789 the caller print a more meaningful message if necessary. */
6790 try
6791 {
6792 struct value *tsd = ada_get_tsd_from_tag (tag);
6793
6794 if (tsd != NULL)
6795 name = ada_tag_name_from_tsd (tsd);
6796 }
6797 catch (const gdb_exception_error &e)
6798 {
6799 }
6800
6801 return name;
6802 }
6803
6804 /* The parent type of TYPE, or NULL if none. */
6805
6806 struct type *
6807 ada_parent_type (struct type *type)
6808 {
6809 int i;
6810
6811 type = ada_check_typedef (type);
6812
6813 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6814 return NULL;
6815
6816 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6817 if (ada_is_parent_field (type, i))
6818 {
6819 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6820
6821 /* If the _parent field is a pointer, then dereference it. */
6822 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6823 parent_type = TYPE_TARGET_TYPE (parent_type);
6824 /* If there is a parallel XVS type, get the actual base type. */
6825 parent_type = ada_get_base_type (parent_type);
6826
6827 return ada_check_typedef (parent_type);
6828 }
6829
6830 return NULL;
6831 }
6832
6833 /* True iff field number FIELD_NUM of structure type TYPE contains the
6834 parent-type (inherited) fields of a derived type. Assumes TYPE is
6835 a structure type with at least FIELD_NUM+1 fields. */
6836
6837 int
6838 ada_is_parent_field (struct type *type, int field_num)
6839 {
6840 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
6841
6842 return (name != NULL
6843 && (startswith (name, "PARENT")
6844 || startswith (name, "_parent")));
6845 }
6846
6847 /* True iff field number FIELD_NUM of structure type TYPE is a
6848 transparent wrapper field (which should be silently traversed when doing
6849 field selection and flattened when printing). Assumes TYPE is a
6850 structure type with at least FIELD_NUM+1 fields. Such fields are always
6851 structures. */
6852
6853 int
6854 ada_is_wrapper_field (struct type *type, int field_num)
6855 {
6856 const char *name = TYPE_FIELD_NAME (type, field_num);
6857
6858 if (name != NULL && strcmp (name, "RETVAL") == 0)
6859 {
6860 /* This happens in functions with "out" or "in out" parameters
6861 which are passed by copy. For such functions, GNAT describes
6862 the function's return type as being a struct where the return
6863 value is in a field called RETVAL, and where the other "out"
6864 or "in out" parameters are fields of that struct. This is not
6865 a wrapper. */
6866 return 0;
6867 }
6868
6869 return (name != NULL
6870 && (startswith (name, "PARENT")
6871 || strcmp (name, "REP") == 0
6872 || startswith (name, "_parent")
6873 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6874 }
6875
6876 /* True iff field number FIELD_NUM of structure or union type TYPE
6877 is a variant wrapper. Assumes TYPE is a structure type with at least
6878 FIELD_NUM+1 fields. */
6879
6880 int
6881 ada_is_variant_part (struct type *type, int field_num)
6882 {
6883 /* Only Ada types are eligible. */
6884 if (!ADA_TYPE_P (type))
6885 return 0;
6886
6887 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
6888
6889 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
6890 || (is_dynamic_field (type, field_num)
6891 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6892 == TYPE_CODE_UNION)));
6893 }
6894
6895 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6896 whose discriminants are contained in the record type OUTER_TYPE,
6897 returns the type of the controlling discriminant for the variant.
6898 May return NULL if the type could not be found. */
6899
6900 struct type *
6901 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6902 {
6903 const char *name = ada_variant_discrim_name (var_type);
6904
6905 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6906 }
6907
6908 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6909 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6910 represents a 'when others' clause; otherwise 0. */
6911
6912 int
6913 ada_is_others_clause (struct type *type, int field_num)
6914 {
6915 const char *name = TYPE_FIELD_NAME (type, field_num);
6916
6917 return (name != NULL && name[0] == 'O');
6918 }
6919
6920 /* Assuming that TYPE0 is the type of the variant part of a record,
6921 returns the name of the discriminant controlling the variant.
6922 The value is valid until the next call to ada_variant_discrim_name. */
6923
6924 const char *
6925 ada_variant_discrim_name (struct type *type0)
6926 {
6927 static char *result = NULL;
6928 static size_t result_len = 0;
6929 struct type *type;
6930 const char *name;
6931 const char *discrim_end;
6932 const char *discrim_start;
6933
6934 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6935 type = TYPE_TARGET_TYPE (type0);
6936 else
6937 type = type0;
6938
6939 name = ada_type_name (type);
6940
6941 if (name == NULL || name[0] == '\000')
6942 return "";
6943
6944 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6945 discrim_end -= 1)
6946 {
6947 if (startswith (discrim_end, "___XVN"))
6948 break;
6949 }
6950 if (discrim_end == name)
6951 return "";
6952
6953 for (discrim_start = discrim_end; discrim_start != name + 3;
6954 discrim_start -= 1)
6955 {
6956 if (discrim_start == name + 1)
6957 return "";
6958 if ((discrim_start > name + 3
6959 && startswith (discrim_start - 3, "___"))
6960 || discrim_start[-1] == '.')
6961 break;
6962 }
6963
6964 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6965 strncpy (result, discrim_start, discrim_end - discrim_start);
6966 result[discrim_end - discrim_start] = '\0';
6967 return result;
6968 }
6969
6970 /* Scan STR for a subtype-encoded number, beginning at position K.
6971 Put the position of the character just past the number scanned in
6972 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6973 Return 1 if there was a valid number at the given position, and 0
6974 otherwise. A "subtype-encoded" number consists of the absolute value
6975 in decimal, followed by the letter 'm' to indicate a negative number.
6976 Assumes 0m does not occur. */
6977
6978 int
6979 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6980 {
6981 ULONGEST RU;
6982
6983 if (!isdigit (str[k]))
6984 return 0;
6985
6986 /* Do it the hard way so as not to make any assumption about
6987 the relationship of unsigned long (%lu scan format code) and
6988 LONGEST. */
6989 RU = 0;
6990 while (isdigit (str[k]))
6991 {
6992 RU = RU * 10 + (str[k] - '0');
6993 k += 1;
6994 }
6995
6996 if (str[k] == 'm')
6997 {
6998 if (R != NULL)
6999 *R = (-(LONGEST) (RU - 1)) - 1;
7000 k += 1;
7001 }
7002 else if (R != NULL)
7003 *R = (LONGEST) RU;
7004
7005 /* NOTE on the above: Technically, C does not say what the results of
7006 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7007 number representable as a LONGEST (although either would probably work
7008 in most implementations). When RU>0, the locution in the then branch
7009 above is always equivalent to the negative of RU. */
7010
7011 if (new_k != NULL)
7012 *new_k = k;
7013 return 1;
7014 }
7015
7016 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7017 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7018 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
7019
7020 int
7021 ada_in_variant (LONGEST val, struct type *type, int field_num)
7022 {
7023 const char *name = TYPE_FIELD_NAME (type, field_num);
7024 int p;
7025
7026 p = 0;
7027 while (1)
7028 {
7029 switch (name[p])
7030 {
7031 case '\0':
7032 return 0;
7033 case 'S':
7034 {
7035 LONGEST W;
7036
7037 if (!ada_scan_number (name, p + 1, &W, &p))
7038 return 0;
7039 if (val == W)
7040 return 1;
7041 break;
7042 }
7043 case 'R':
7044 {
7045 LONGEST L, U;
7046
7047 if (!ada_scan_number (name, p + 1, &L, &p)
7048 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7049 return 0;
7050 if (val >= L && val <= U)
7051 return 1;
7052 break;
7053 }
7054 case 'O':
7055 return 1;
7056 default:
7057 return 0;
7058 }
7059 }
7060 }
7061
7062 /* FIXME: Lots of redundancy below. Try to consolidate. */
7063
7064 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7065 ARG_TYPE, extract and return the value of one of its (non-static)
7066 fields. FIELDNO says which field. Differs from value_primitive_field
7067 only in that it can handle packed values of arbitrary type. */
7068
7069 static struct value *
7070 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
7071 struct type *arg_type)
7072 {
7073 struct type *type;
7074
7075 arg_type = ada_check_typedef (arg_type);
7076 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7077
7078 /* Handle packed fields. It might be that the field is not packed
7079 relative to its containing structure, but the structure itself is
7080 packed; in this case we must take the bit-field path. */
7081 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
7082 {
7083 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7084 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
7085
7086 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
7087 offset + bit_pos / 8,
7088 bit_pos % 8, bit_size, type);
7089 }
7090 else
7091 return value_primitive_field (arg1, offset, fieldno, arg_type);
7092 }
7093
7094 /* Find field with name NAME in object of type TYPE. If found,
7095 set the following for each argument that is non-null:
7096 - *FIELD_TYPE_P to the field's type;
7097 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7098 an object of that type;
7099 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7100 - *BIT_SIZE_P to its size in bits if the field is packed, and
7101 0 otherwise;
7102 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7103 fields up to but not including the desired field, or by the total
7104 number of fields if not found. A NULL value of NAME never
7105 matches; the function just counts visible fields in this case.
7106
7107 Notice that we need to handle when a tagged record hierarchy
7108 has some components with the same name, like in this scenario:
7109
7110 type Top_T is tagged record
7111 N : Integer := 1;
7112 U : Integer := 974;
7113 A : Integer := 48;
7114 end record;
7115
7116 type Middle_T is new Top.Top_T with record
7117 N : Character := 'a';
7118 C : Integer := 3;
7119 end record;
7120
7121 type Bottom_T is new Middle.Middle_T with record
7122 N : Float := 4.0;
7123 C : Character := '5';
7124 X : Integer := 6;
7125 A : Character := 'J';
7126 end record;
7127
7128 Let's say we now have a variable declared and initialized as follow:
7129
7130 TC : Top_A := new Bottom_T;
7131
7132 And then we use this variable to call this function
7133
7134 procedure Assign (Obj: in out Top_T; TV : Integer);
7135
7136 as follow:
7137
7138 Assign (Top_T (B), 12);
7139
7140 Now, we're in the debugger, and we're inside that procedure
7141 then and we want to print the value of obj.c:
7142
7143 Usually, the tagged record or one of the parent type owns the
7144 component to print and there's no issue but in this particular
7145 case, what does it mean to ask for Obj.C? Since the actual
7146 type for object is type Bottom_T, it could mean two things: type
7147 component C from the Middle_T view, but also component C from
7148 Bottom_T. So in that "undefined" case, when the component is
7149 not found in the non-resolved type (which includes all the
7150 components of the parent type), then resolve it and see if we
7151 get better luck once expanded.
7152
7153 In the case of homonyms in the derived tagged type, we don't
7154 guaranty anything, and pick the one that's easiest for us
7155 to program.
7156
7157 Returns 1 if found, 0 otherwise. */
7158
7159 static int
7160 find_struct_field (const char *name, struct type *type, int offset,
7161 struct type **field_type_p,
7162 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7163 int *index_p)
7164 {
7165 int i;
7166 int parent_offset = -1;
7167
7168 type = ada_check_typedef (type);
7169
7170 if (field_type_p != NULL)
7171 *field_type_p = NULL;
7172 if (byte_offset_p != NULL)
7173 *byte_offset_p = 0;
7174 if (bit_offset_p != NULL)
7175 *bit_offset_p = 0;
7176 if (bit_size_p != NULL)
7177 *bit_size_p = 0;
7178
7179 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7180 {
7181 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7182 int fld_offset = offset + bit_pos / 8;
7183 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7184
7185 if (t_field_name == NULL)
7186 continue;
7187
7188 else if (ada_is_parent_field (type, i))
7189 {
7190 /* This is a field pointing us to the parent type of a tagged
7191 type. As hinted in this function's documentation, we give
7192 preference to fields in the current record first, so what
7193 we do here is just record the index of this field before
7194 we skip it. If it turns out we couldn't find our field
7195 in the current record, then we'll get back to it and search
7196 inside it whether the field might exist in the parent. */
7197
7198 parent_offset = i;
7199 continue;
7200 }
7201
7202 else if (name != NULL && field_name_match (t_field_name, name))
7203 {
7204 int bit_size = TYPE_FIELD_BITSIZE (type, i);
7205
7206 if (field_type_p != NULL)
7207 *field_type_p = TYPE_FIELD_TYPE (type, i);
7208 if (byte_offset_p != NULL)
7209 *byte_offset_p = fld_offset;
7210 if (bit_offset_p != NULL)
7211 *bit_offset_p = bit_pos % 8;
7212 if (bit_size_p != NULL)
7213 *bit_size_p = bit_size;
7214 return 1;
7215 }
7216 else if (ada_is_wrapper_field (type, i))
7217 {
7218 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7219 field_type_p, byte_offset_p, bit_offset_p,
7220 bit_size_p, index_p))
7221 return 1;
7222 }
7223 else if (ada_is_variant_part (type, i))
7224 {
7225 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7226 fixed type?? */
7227 int j;
7228 struct type *field_type
7229 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
7230
7231 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7232 {
7233 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7234 fld_offset
7235 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7236 field_type_p, byte_offset_p,
7237 bit_offset_p, bit_size_p, index_p))
7238 return 1;
7239 }
7240 }
7241 else if (index_p != NULL)
7242 *index_p += 1;
7243 }
7244
7245 /* Field not found so far. If this is a tagged type which
7246 has a parent, try finding that field in the parent now. */
7247
7248 if (parent_offset != -1)
7249 {
7250 int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
7251 int fld_offset = offset + bit_pos / 8;
7252
7253 if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset),
7254 fld_offset, field_type_p, byte_offset_p,
7255 bit_offset_p, bit_size_p, index_p))
7256 return 1;
7257 }
7258
7259 return 0;
7260 }
7261
7262 /* Number of user-visible fields in record type TYPE. */
7263
7264 static int
7265 num_visible_fields (struct type *type)
7266 {
7267 int n;
7268
7269 n = 0;
7270 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7271 return n;
7272 }
7273
7274 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7275 and search in it assuming it has (class) type TYPE.
7276 If found, return value, else return NULL.
7277
7278 Searches recursively through wrapper fields (e.g., '_parent').
7279
7280 In the case of homonyms in the tagged types, please refer to the
7281 long explanation in find_struct_field's function documentation. */
7282
7283 static struct value *
7284 ada_search_struct_field (const char *name, struct value *arg, int offset,
7285 struct type *type)
7286 {
7287 int i;
7288 int parent_offset = -1;
7289
7290 type = ada_check_typedef (type);
7291 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7292 {
7293 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7294
7295 if (t_field_name == NULL)
7296 continue;
7297
7298 else if (ada_is_parent_field (type, i))
7299 {
7300 /* This is a field pointing us to the parent type of a tagged
7301 type. As hinted in this function's documentation, we give
7302 preference to fields in the current record first, so what
7303 we do here is just record the index of this field before
7304 we skip it. If it turns out we couldn't find our field
7305 in the current record, then we'll get back to it and search
7306 inside it whether the field might exist in the parent. */
7307
7308 parent_offset = i;
7309 continue;
7310 }
7311
7312 else if (field_name_match (t_field_name, name))
7313 return ada_value_primitive_field (arg, offset, i, type);
7314
7315 else if (ada_is_wrapper_field (type, i))
7316 {
7317 struct value *v = /* Do not let indent join lines here. */
7318 ada_search_struct_field (name, arg,
7319 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7320 TYPE_FIELD_TYPE (type, i));
7321
7322 if (v != NULL)
7323 return v;
7324 }
7325
7326 else if (ada_is_variant_part (type, i))
7327 {
7328 /* PNH: Do we ever get here? See find_struct_field. */
7329 int j;
7330 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7331 i));
7332 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7333
7334 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7335 {
7336 struct value *v = ada_search_struct_field /* Force line
7337 break. */
7338 (name, arg,
7339 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7340 TYPE_FIELD_TYPE (field_type, j));
7341
7342 if (v != NULL)
7343 return v;
7344 }
7345 }
7346 }
7347
7348 /* Field not found so far. If this is a tagged type which
7349 has a parent, try finding that field in the parent now. */
7350
7351 if (parent_offset != -1)
7352 {
7353 struct value *v = ada_search_struct_field (
7354 name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
7355 TYPE_FIELD_TYPE (type, parent_offset));
7356
7357 if (v != NULL)
7358 return v;
7359 }
7360
7361 return NULL;
7362 }
7363
7364 static struct value *ada_index_struct_field_1 (int *, struct value *,
7365 int, struct type *);
7366
7367
7368 /* Return field #INDEX in ARG, where the index is that returned by
7369 * find_struct_field through its INDEX_P argument. Adjust the address
7370 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7371 * If found, return value, else return NULL. */
7372
7373 static struct value *
7374 ada_index_struct_field (int index, struct value *arg, int offset,
7375 struct type *type)
7376 {
7377 return ada_index_struct_field_1 (&index, arg, offset, type);
7378 }
7379
7380
7381 /* Auxiliary function for ada_index_struct_field. Like
7382 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7383 * *INDEX_P. */
7384
7385 static struct value *
7386 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7387 struct type *type)
7388 {
7389 int i;
7390 type = ada_check_typedef (type);
7391
7392 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7393 {
7394 if (TYPE_FIELD_NAME (type, i) == NULL)
7395 continue;
7396 else if (ada_is_wrapper_field (type, i))
7397 {
7398 struct value *v = /* Do not let indent join lines here. */
7399 ada_index_struct_field_1 (index_p, arg,
7400 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7401 TYPE_FIELD_TYPE (type, i));
7402
7403 if (v != NULL)
7404 return v;
7405 }
7406
7407 else if (ada_is_variant_part (type, i))
7408 {
7409 /* PNH: Do we ever get here? See ada_search_struct_field,
7410 find_struct_field. */
7411 error (_("Cannot assign this kind of variant record"));
7412 }
7413 else if (*index_p == 0)
7414 return ada_value_primitive_field (arg, offset, i, type);
7415 else
7416 *index_p -= 1;
7417 }
7418 return NULL;
7419 }
7420
7421 /* Given ARG, a value of type (pointer or reference to a)*
7422 structure/union, extract the component named NAME from the ultimate
7423 target structure/union and return it as a value with its
7424 appropriate type.
7425
7426 The routine searches for NAME among all members of the structure itself
7427 and (recursively) among all members of any wrapper members
7428 (e.g., '_parent').
7429
7430 If NO_ERR, then simply return NULL in case of error, rather than
7431 calling error. */
7432
7433 struct value *
7434 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
7435 {
7436 struct type *t, *t1;
7437 struct value *v;
7438 int check_tag;
7439
7440 v = NULL;
7441 t1 = t = ada_check_typedef (value_type (arg));
7442 if (TYPE_CODE (t) == TYPE_CODE_REF)
7443 {
7444 t1 = TYPE_TARGET_TYPE (t);
7445 if (t1 == NULL)
7446 goto BadValue;
7447 t1 = ada_check_typedef (t1);
7448 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7449 {
7450 arg = coerce_ref (arg);
7451 t = t1;
7452 }
7453 }
7454
7455 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7456 {
7457 t1 = TYPE_TARGET_TYPE (t);
7458 if (t1 == NULL)
7459 goto BadValue;
7460 t1 = ada_check_typedef (t1);
7461 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7462 {
7463 arg = value_ind (arg);
7464 t = t1;
7465 }
7466 else
7467 break;
7468 }
7469
7470 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
7471 goto BadValue;
7472
7473 if (t1 == t)
7474 v = ada_search_struct_field (name, arg, 0, t);
7475 else
7476 {
7477 int bit_offset, bit_size, byte_offset;
7478 struct type *field_type;
7479 CORE_ADDR address;
7480
7481 if (TYPE_CODE (t) == TYPE_CODE_PTR)
7482 address = value_address (ada_value_ind (arg));
7483 else
7484 address = value_address (ada_coerce_ref (arg));
7485
7486 /* Check to see if this is a tagged type. We also need to handle
7487 the case where the type is a reference to a tagged type, but
7488 we have to be careful to exclude pointers to tagged types.
7489 The latter should be shown as usual (as a pointer), whereas
7490 a reference should mostly be transparent to the user. */
7491
7492 if (ada_is_tagged_type (t1, 0)
7493 || (TYPE_CODE (t1) == TYPE_CODE_REF
7494 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
7495 {
7496 /* We first try to find the searched field in the current type.
7497 If not found then let's look in the fixed type. */
7498
7499 if (!find_struct_field (name, t1, 0,
7500 &field_type, &byte_offset, &bit_offset,
7501 &bit_size, NULL))
7502 check_tag = 1;
7503 else
7504 check_tag = 0;
7505 }
7506 else
7507 check_tag = 0;
7508
7509 /* Convert to fixed type in all cases, so that we have proper
7510 offsets to each field in unconstrained record types. */
7511 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7512 address, NULL, check_tag);
7513
7514 if (find_struct_field (name, t1, 0,
7515 &field_type, &byte_offset, &bit_offset,
7516 &bit_size, NULL))
7517 {
7518 if (bit_size != 0)
7519 {
7520 if (TYPE_CODE (t) == TYPE_CODE_REF)
7521 arg = ada_coerce_ref (arg);
7522 else
7523 arg = ada_value_ind (arg);
7524 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7525 bit_offset, bit_size,
7526 field_type);
7527 }
7528 else
7529 v = value_at_lazy (field_type, address + byte_offset);
7530 }
7531 }
7532
7533 if (v != NULL || no_err)
7534 return v;
7535 else
7536 error (_("There is no member named %s."), name);
7537
7538 BadValue:
7539 if (no_err)
7540 return NULL;
7541 else
7542 error (_("Attempt to extract a component of "
7543 "a value that is not a record."));
7544 }
7545
7546 /* Return a string representation of type TYPE. */
7547
7548 static std::string
7549 type_as_string (struct type *type)
7550 {
7551 string_file tmp_stream;
7552
7553 type_print (type, "", &tmp_stream, -1);
7554
7555 return std::move (tmp_stream.string ());
7556 }
7557
7558 /* Given a type TYPE, look up the type of the component of type named NAME.
7559 If DISPP is non-null, add its byte displacement from the beginning of a
7560 structure (pointed to by a value) of type TYPE to *DISPP (does not
7561 work for packed fields).
7562
7563 Matches any field whose name has NAME as a prefix, possibly
7564 followed by "___".
7565
7566 TYPE can be either a struct or union. If REFOK, TYPE may also
7567 be a (pointer or reference)+ to a struct or union, and the
7568 ultimate target type will be searched.
7569
7570 Looks recursively into variant clauses and parent types.
7571
7572 In the case of homonyms in the tagged types, please refer to the
7573 long explanation in find_struct_field's function documentation.
7574
7575 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7576 TYPE is not a type of the right kind. */
7577
7578 static struct type *
7579 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7580 int noerr)
7581 {
7582 int i;
7583 int parent_offset = -1;
7584
7585 if (name == NULL)
7586 goto BadName;
7587
7588 if (refok && type != NULL)
7589 while (1)
7590 {
7591 type = ada_check_typedef (type);
7592 if (TYPE_CODE (type) != TYPE_CODE_PTR
7593 && TYPE_CODE (type) != TYPE_CODE_REF)
7594 break;
7595 type = TYPE_TARGET_TYPE (type);
7596 }
7597
7598 if (type == NULL
7599 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7600 && TYPE_CODE (type) != TYPE_CODE_UNION))
7601 {
7602 if (noerr)
7603 return NULL;
7604
7605 error (_("Type %s is not a structure or union type"),
7606 type != NULL ? type_as_string (type).c_str () : _("(null)"));
7607 }
7608
7609 type = to_static_fixed_type (type);
7610
7611 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7612 {
7613 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7614 struct type *t;
7615
7616 if (t_field_name == NULL)
7617 continue;
7618
7619 else if (ada_is_parent_field (type, i))
7620 {
7621 /* This is a field pointing us to the parent type of a tagged
7622 type. As hinted in this function's documentation, we give
7623 preference to fields in the current record first, so what
7624 we do here is just record the index of this field before
7625 we skip it. If it turns out we couldn't find our field
7626 in the current record, then we'll get back to it and search
7627 inside it whether the field might exist in the parent. */
7628
7629 parent_offset = i;
7630 continue;
7631 }
7632
7633 else if (field_name_match (t_field_name, name))
7634 return TYPE_FIELD_TYPE (type, i);
7635
7636 else if (ada_is_wrapper_field (type, i))
7637 {
7638 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7639 0, 1);
7640 if (t != NULL)
7641 return t;
7642 }
7643
7644 else if (ada_is_variant_part (type, i))
7645 {
7646 int j;
7647 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7648 i));
7649
7650 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7651 {
7652 /* FIXME pnh 2008/01/26: We check for a field that is
7653 NOT wrapped in a struct, since the compiler sometimes
7654 generates these for unchecked variant types. Revisit
7655 if the compiler changes this practice. */
7656 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
7657
7658 if (v_field_name != NULL
7659 && field_name_match (v_field_name, name))
7660 t = TYPE_FIELD_TYPE (field_type, j);
7661 else
7662 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7663 j),
7664 name, 0, 1);
7665
7666 if (t != NULL)
7667 return t;
7668 }
7669 }
7670
7671 }
7672
7673 /* Field not found so far. If this is a tagged type which
7674 has a parent, try finding that field in the parent now. */
7675
7676 if (parent_offset != -1)
7677 {
7678 struct type *t;
7679
7680 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset),
7681 name, 0, 1);
7682 if (t != NULL)
7683 return t;
7684 }
7685
7686 BadName:
7687 if (!noerr)
7688 {
7689 const char *name_str = name != NULL ? name : _("<null>");
7690
7691 error (_("Type %s has no component named %s"),
7692 type_as_string (type).c_str (), name_str);
7693 }
7694
7695 return NULL;
7696 }
7697
7698 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7699 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7700 represents an unchecked union (that is, the variant part of a
7701 record that is named in an Unchecked_Union pragma). */
7702
7703 static int
7704 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7705 {
7706 const char *discrim_name = ada_variant_discrim_name (var_type);
7707
7708 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7709 }
7710
7711
7712 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7713 within a value of type OUTER_TYPE that is stored in GDB at
7714 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7715 numbering from 0) is applicable. Returns -1 if none are. */
7716
7717 int
7718 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
7719 const gdb_byte *outer_valaddr)
7720 {
7721 int others_clause;
7722 int i;
7723 const char *discrim_name = ada_variant_discrim_name (var_type);
7724 struct value *outer;
7725 struct value *discrim;
7726 LONGEST discrim_val;
7727
7728 /* Using plain value_from_contents_and_address here causes problems
7729 because we will end up trying to resolve a type that is currently
7730 being constructed. */
7731 outer = value_from_contents_and_address_unresolved (outer_type,
7732 outer_valaddr, 0);
7733 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7734 if (discrim == NULL)
7735 return -1;
7736 discrim_val = value_as_long (discrim);
7737
7738 others_clause = -1;
7739 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7740 {
7741 if (ada_is_others_clause (var_type, i))
7742 others_clause = i;
7743 else if (ada_in_variant (discrim_val, var_type, i))
7744 return i;
7745 }
7746
7747 return others_clause;
7748 }
7749 \f
7750
7751
7752 /* Dynamic-Sized Records */
7753
7754 /* Strategy: The type ostensibly attached to a value with dynamic size
7755 (i.e., a size that is not statically recorded in the debugging
7756 data) does not accurately reflect the size or layout of the value.
7757 Our strategy is to convert these values to values with accurate,
7758 conventional types that are constructed on the fly. */
7759
7760 /* There is a subtle and tricky problem here. In general, we cannot
7761 determine the size of dynamic records without its data. However,
7762 the 'struct value' data structure, which GDB uses to represent
7763 quantities in the inferior process (the target), requires the size
7764 of the type at the time of its allocation in order to reserve space
7765 for GDB's internal copy of the data. That's why the
7766 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7767 rather than struct value*s.
7768
7769 However, GDB's internal history variables ($1, $2, etc.) are
7770 struct value*s containing internal copies of the data that are not, in
7771 general, the same as the data at their corresponding addresses in
7772 the target. Fortunately, the types we give to these values are all
7773 conventional, fixed-size types (as per the strategy described
7774 above), so that we don't usually have to perform the
7775 'to_fixed_xxx_type' conversions to look at their values.
7776 Unfortunately, there is one exception: if one of the internal
7777 history variables is an array whose elements are unconstrained
7778 records, then we will need to create distinct fixed types for each
7779 element selected. */
7780
7781 /* The upshot of all of this is that many routines take a (type, host
7782 address, target address) triple as arguments to represent a value.
7783 The host address, if non-null, is supposed to contain an internal
7784 copy of the relevant data; otherwise, the program is to consult the
7785 target at the target address. */
7786
7787 /* Assuming that VAL0 represents a pointer value, the result of
7788 dereferencing it. Differs from value_ind in its treatment of
7789 dynamic-sized types. */
7790
7791 struct value *
7792 ada_value_ind (struct value *val0)
7793 {
7794 struct value *val = value_ind (val0);
7795
7796 if (ada_is_tagged_type (value_type (val), 0))
7797 val = ada_tag_value_at_base_address (val);
7798
7799 return ada_to_fixed_value (val);
7800 }
7801
7802 /* The value resulting from dereferencing any "reference to"
7803 qualifiers on VAL0. */
7804
7805 static struct value *
7806 ada_coerce_ref (struct value *val0)
7807 {
7808 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
7809 {
7810 struct value *val = val0;
7811
7812 val = coerce_ref (val);
7813
7814 if (ada_is_tagged_type (value_type (val), 0))
7815 val = ada_tag_value_at_base_address (val);
7816
7817 return ada_to_fixed_value (val);
7818 }
7819 else
7820 return val0;
7821 }
7822
7823 /* Return OFF rounded upward if necessary to a multiple of
7824 ALIGNMENT (a power of 2). */
7825
7826 static unsigned int
7827 align_value (unsigned int off, unsigned int alignment)
7828 {
7829 return (off + alignment - 1) & ~(alignment - 1);
7830 }
7831
7832 /* Return the bit alignment required for field #F of template type TYPE. */
7833
7834 static unsigned int
7835 field_alignment (struct type *type, int f)
7836 {
7837 const char *name = TYPE_FIELD_NAME (type, f);
7838 int len;
7839 int align_offset;
7840
7841 /* The field name should never be null, unless the debugging information
7842 is somehow malformed. In this case, we assume the field does not
7843 require any alignment. */
7844 if (name == NULL)
7845 return 1;
7846
7847 len = strlen (name);
7848
7849 if (!isdigit (name[len - 1]))
7850 return 1;
7851
7852 if (isdigit (name[len - 2]))
7853 align_offset = len - 2;
7854 else
7855 align_offset = len - 1;
7856
7857 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7858 return TARGET_CHAR_BIT;
7859
7860 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7861 }
7862
7863 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7864
7865 static struct symbol *
7866 ada_find_any_type_symbol (const char *name)
7867 {
7868 struct symbol *sym;
7869
7870 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7871 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7872 return sym;
7873
7874 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7875 return sym;
7876 }
7877
7878 /* Find a type named NAME. Ignores ambiguity. This routine will look
7879 solely for types defined by debug info, it will not search the GDB
7880 primitive types. */
7881
7882 static struct type *
7883 ada_find_any_type (const char *name)
7884 {
7885 struct symbol *sym = ada_find_any_type_symbol (name);
7886
7887 if (sym != NULL)
7888 return SYMBOL_TYPE (sym);
7889
7890 return NULL;
7891 }
7892
7893 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7894 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7895 symbol, in which case it is returned. Otherwise, this looks for
7896 symbols whose name is that of NAME_SYM suffixed with "___XR".
7897 Return symbol if found, and NULL otherwise. */
7898
7899 static bool
7900 ada_is_renaming_symbol (struct symbol *name_sym)
7901 {
7902 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
7903 return strstr (name, "___XR") != NULL;
7904 }
7905
7906 /* Because of GNAT encoding conventions, several GDB symbols may match a
7907 given type name. If the type denoted by TYPE0 is to be preferred to
7908 that of TYPE1 for purposes of type printing, return non-zero;
7909 otherwise return 0. */
7910
7911 int
7912 ada_prefer_type (struct type *type0, struct type *type1)
7913 {
7914 if (type1 == NULL)
7915 return 1;
7916 else if (type0 == NULL)
7917 return 0;
7918 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7919 return 1;
7920 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7921 return 0;
7922 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7923 return 1;
7924 else if (ada_is_constrained_packed_array_type (type0))
7925 return 1;
7926 else if (ada_is_array_descriptor_type (type0)
7927 && !ada_is_array_descriptor_type (type1))
7928 return 1;
7929 else
7930 {
7931 const char *type0_name = TYPE_NAME (type0);
7932 const char *type1_name = TYPE_NAME (type1);
7933
7934 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7935 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7936 return 1;
7937 }
7938 return 0;
7939 }
7940
7941 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7942 null. */
7943
7944 const char *
7945 ada_type_name (struct type *type)
7946 {
7947 if (type == NULL)
7948 return NULL;
7949 return TYPE_NAME (type);
7950 }
7951
7952 /* Search the list of "descriptive" types associated to TYPE for a type
7953 whose name is NAME. */
7954
7955 static struct type *
7956 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7957 {
7958 struct type *result, *tmp;
7959
7960 if (ada_ignore_descriptive_types_p)
7961 return NULL;
7962
7963 /* If there no descriptive-type info, then there is no parallel type
7964 to be found. */
7965 if (!HAVE_GNAT_AUX_INFO (type))
7966 return NULL;
7967
7968 result = TYPE_DESCRIPTIVE_TYPE (type);
7969 while (result != NULL)
7970 {
7971 const char *result_name = ada_type_name (result);
7972
7973 if (result_name == NULL)
7974 {
7975 warning (_("unexpected null name on descriptive type"));
7976 return NULL;
7977 }
7978
7979 /* If the names match, stop. */
7980 if (strcmp (result_name, name) == 0)
7981 break;
7982
7983 /* Otherwise, look at the next item on the list, if any. */
7984 if (HAVE_GNAT_AUX_INFO (result))
7985 tmp = TYPE_DESCRIPTIVE_TYPE (result);
7986 else
7987 tmp = NULL;
7988
7989 /* If not found either, try after having resolved the typedef. */
7990 if (tmp != NULL)
7991 result = tmp;
7992 else
7993 {
7994 result = check_typedef (result);
7995 if (HAVE_GNAT_AUX_INFO (result))
7996 result = TYPE_DESCRIPTIVE_TYPE (result);
7997 else
7998 result = NULL;
7999 }
8000 }
8001
8002 /* If we didn't find a match, see whether this is a packed array. With
8003 older compilers, the descriptive type information is either absent or
8004 irrelevant when it comes to packed arrays so the above lookup fails.
8005 Fall back to using a parallel lookup by name in this case. */
8006 if (result == NULL && ada_is_constrained_packed_array_type (type))
8007 return ada_find_any_type (name);
8008
8009 return result;
8010 }
8011
8012 /* Find a parallel type to TYPE with the specified NAME, using the
8013 descriptive type taken from the debugging information, if available,
8014 and otherwise using the (slower) name-based method. */
8015
8016 static struct type *
8017 ada_find_parallel_type_with_name (struct type *type, const char *name)
8018 {
8019 struct type *result = NULL;
8020
8021 if (HAVE_GNAT_AUX_INFO (type))
8022 result = find_parallel_type_by_descriptive_type (type, name);
8023 else
8024 result = ada_find_any_type (name);
8025
8026 return result;
8027 }
8028
8029 /* Same as above, but specify the name of the parallel type by appending
8030 SUFFIX to the name of TYPE. */
8031
8032 struct type *
8033 ada_find_parallel_type (struct type *type, const char *suffix)
8034 {
8035 char *name;
8036 const char *type_name = ada_type_name (type);
8037 int len;
8038
8039 if (type_name == NULL)
8040 return NULL;
8041
8042 len = strlen (type_name);
8043
8044 name = (char *) alloca (len + strlen (suffix) + 1);
8045
8046 strcpy (name, type_name);
8047 strcpy (name + len, suffix);
8048
8049 return ada_find_parallel_type_with_name (type, name);
8050 }
8051
8052 /* If TYPE is a variable-size record type, return the corresponding template
8053 type describing its fields. Otherwise, return NULL. */
8054
8055 static struct type *
8056 dynamic_template_type (struct type *type)
8057 {
8058 type = ada_check_typedef (type);
8059
8060 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
8061 || ada_type_name (type) == NULL)
8062 return NULL;
8063 else
8064 {
8065 int len = strlen (ada_type_name (type));
8066
8067 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8068 return type;
8069 else
8070 return ada_find_parallel_type (type, "___XVE");
8071 }
8072 }
8073
8074 /* Assuming that TEMPL_TYPE is a union or struct type, returns
8075 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
8076
8077 static int
8078 is_dynamic_field (struct type *templ_type, int field_num)
8079 {
8080 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
8081
8082 return name != NULL
8083 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8084 && strstr (name, "___XVL") != NULL;
8085 }
8086
8087 /* The index of the variant field of TYPE, or -1 if TYPE does not
8088 represent a variant record type. */
8089
8090 static int
8091 variant_field_index (struct type *type)
8092 {
8093 int f;
8094
8095 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8096 return -1;
8097
8098 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8099 {
8100 if (ada_is_variant_part (type, f))
8101 return f;
8102 }
8103 return -1;
8104 }
8105
8106 /* A record type with no fields. */
8107
8108 static struct type *
8109 empty_record (struct type *templ)
8110 {
8111 struct type *type = alloc_type_copy (templ);
8112
8113 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8114 TYPE_NFIELDS (type) = 0;
8115 TYPE_FIELDS (type) = NULL;
8116 INIT_NONE_SPECIFIC (type);
8117 TYPE_NAME (type) = "<empty>";
8118 TYPE_LENGTH (type) = 0;
8119 return type;
8120 }
8121
8122 /* An ordinary record type (with fixed-length fields) that describes
8123 the value of type TYPE at VALADDR or ADDRESS (see comments at
8124 the beginning of this section) VAL according to GNAT conventions.
8125 DVAL0 should describe the (portion of a) record that contains any
8126 necessary discriminants. It should be NULL if value_type (VAL) is
8127 an outer-level type (i.e., as opposed to a branch of a variant.) A
8128 variant field (unless unchecked) is replaced by a particular branch
8129 of the variant.
8130
8131 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8132 length are not statically known are discarded. As a consequence,
8133 VALADDR, ADDRESS and DVAL0 are ignored.
8134
8135 NOTE: Limitations: For now, we assume that dynamic fields and
8136 variants occupy whole numbers of bytes. However, they need not be
8137 byte-aligned. */
8138
8139 struct type *
8140 ada_template_to_fixed_record_type_1 (struct type *type,
8141 const gdb_byte *valaddr,
8142 CORE_ADDR address, struct value *dval0,
8143 int keep_dynamic_fields)
8144 {
8145 struct value *mark = value_mark ();
8146 struct value *dval;
8147 struct type *rtype;
8148 int nfields, bit_len;
8149 int variant_field;
8150 long off;
8151 int fld_bit_len;
8152 int f;
8153
8154 /* Compute the number of fields in this record type that are going
8155 to be processed: unless keep_dynamic_fields, this includes only
8156 fields whose position and length are static will be processed. */
8157 if (keep_dynamic_fields)
8158 nfields = TYPE_NFIELDS (type);
8159 else
8160 {
8161 nfields = 0;
8162 while (nfields < TYPE_NFIELDS (type)
8163 && !ada_is_variant_part (type, nfields)
8164 && !is_dynamic_field (type, nfields))
8165 nfields++;
8166 }
8167
8168 rtype = alloc_type_copy (type);
8169 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8170 INIT_NONE_SPECIFIC (rtype);
8171 TYPE_NFIELDS (rtype) = nfields;
8172 TYPE_FIELDS (rtype) = (struct field *)
8173 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8174 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8175 TYPE_NAME (rtype) = ada_type_name (type);
8176 TYPE_FIXED_INSTANCE (rtype) = 1;
8177
8178 off = 0;
8179 bit_len = 0;
8180 variant_field = -1;
8181
8182 for (f = 0; f < nfields; f += 1)
8183 {
8184 off = align_value (off, field_alignment (type, f))
8185 + TYPE_FIELD_BITPOS (type, f);
8186 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
8187 TYPE_FIELD_BITSIZE (rtype, f) = 0;
8188
8189 if (ada_is_variant_part (type, f))
8190 {
8191 variant_field = f;
8192 fld_bit_len = 0;
8193 }
8194 else if (is_dynamic_field (type, f))
8195 {
8196 const gdb_byte *field_valaddr = valaddr;
8197 CORE_ADDR field_address = address;
8198 struct type *field_type =
8199 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8200
8201 if (dval0 == NULL)
8202 {
8203 /* rtype's length is computed based on the run-time
8204 value of discriminants. If the discriminants are not
8205 initialized, the type size may be completely bogus and
8206 GDB may fail to allocate a value for it. So check the
8207 size first before creating the value. */
8208 ada_ensure_varsize_limit (rtype);
8209 /* Using plain value_from_contents_and_address here
8210 causes problems because we will end up trying to
8211 resolve a type that is currently being
8212 constructed. */
8213 dval = value_from_contents_and_address_unresolved (rtype,
8214 valaddr,
8215 address);
8216 rtype = value_type (dval);
8217 }
8218 else
8219 dval = dval0;
8220
8221 /* If the type referenced by this field is an aligner type, we need
8222 to unwrap that aligner type, because its size might not be set.
8223 Keeping the aligner type would cause us to compute the wrong
8224 size for this field, impacting the offset of the all the fields
8225 that follow this one. */
8226 if (ada_is_aligner_type (field_type))
8227 {
8228 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8229
8230 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8231 field_address = cond_offset_target (field_address, field_offset);
8232 field_type = ada_aligned_type (field_type);
8233 }
8234
8235 field_valaddr = cond_offset_host (field_valaddr,
8236 off / TARGET_CHAR_BIT);
8237 field_address = cond_offset_target (field_address,
8238 off / TARGET_CHAR_BIT);
8239
8240 /* Get the fixed type of the field. Note that, in this case,
8241 we do not want to get the real type out of the tag: if
8242 the current field is the parent part of a tagged record,
8243 we will get the tag of the object. Clearly wrong: the real
8244 type of the parent is not the real type of the child. We
8245 would end up in an infinite loop. */
8246 field_type = ada_get_base_type (field_type);
8247 field_type = ada_to_fixed_type (field_type, field_valaddr,
8248 field_address, dval, 0);
8249 /* If the field size is already larger than the maximum
8250 object size, then the record itself will necessarily
8251 be larger than the maximum object size. We need to make
8252 this check now, because the size might be so ridiculously
8253 large (due to an uninitialized variable in the inferior)
8254 that it would cause an overflow when adding it to the
8255 record size. */
8256 ada_ensure_varsize_limit (field_type);
8257
8258 TYPE_FIELD_TYPE (rtype, f) = field_type;
8259 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8260 /* The multiplication can potentially overflow. But because
8261 the field length has been size-checked just above, and
8262 assuming that the maximum size is a reasonable value,
8263 an overflow should not happen in practice. So rather than
8264 adding overflow recovery code to this already complex code,
8265 we just assume that it's not going to happen. */
8266 fld_bit_len =
8267 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8268 }
8269 else
8270 {
8271 /* Note: If this field's type is a typedef, it is important
8272 to preserve the typedef layer.
8273
8274 Otherwise, we might be transforming a typedef to a fat
8275 pointer (encoding a pointer to an unconstrained array),
8276 into a basic fat pointer (encoding an unconstrained
8277 array). As both types are implemented using the same
8278 structure, the typedef is the only clue which allows us
8279 to distinguish between the two options. Stripping it
8280 would prevent us from printing this field appropriately. */
8281 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
8282 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8283 if (TYPE_FIELD_BITSIZE (type, f) > 0)
8284 fld_bit_len =
8285 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8286 else
8287 {
8288 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8289
8290 /* We need to be careful of typedefs when computing
8291 the length of our field. If this is a typedef,
8292 get the length of the target type, not the length
8293 of the typedef. */
8294 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8295 field_type = ada_typedef_target_type (field_type);
8296
8297 fld_bit_len =
8298 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8299 }
8300 }
8301 if (off + fld_bit_len > bit_len)
8302 bit_len = off + fld_bit_len;
8303 off += fld_bit_len;
8304 TYPE_LENGTH (rtype) =
8305 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8306 }
8307
8308 /* We handle the variant part, if any, at the end because of certain
8309 odd cases in which it is re-ordered so as NOT to be the last field of
8310 the record. This can happen in the presence of representation
8311 clauses. */
8312 if (variant_field >= 0)
8313 {
8314 struct type *branch_type;
8315
8316 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8317
8318 if (dval0 == NULL)
8319 {
8320 /* Using plain value_from_contents_and_address here causes
8321 problems because we will end up trying to resolve a type
8322 that is currently being constructed. */
8323 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8324 address);
8325 rtype = value_type (dval);
8326 }
8327 else
8328 dval = dval0;
8329
8330 branch_type =
8331 to_fixed_variant_branch_type
8332 (TYPE_FIELD_TYPE (type, variant_field),
8333 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8334 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8335 if (branch_type == NULL)
8336 {
8337 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8338 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8339 TYPE_NFIELDS (rtype) -= 1;
8340 }
8341 else
8342 {
8343 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8344 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8345 fld_bit_len =
8346 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8347 TARGET_CHAR_BIT;
8348 if (off + fld_bit_len > bit_len)
8349 bit_len = off + fld_bit_len;
8350 TYPE_LENGTH (rtype) =
8351 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8352 }
8353 }
8354
8355 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8356 should contain the alignment of that record, which should be a strictly
8357 positive value. If null or negative, then something is wrong, most
8358 probably in the debug info. In that case, we don't round up the size
8359 of the resulting type. If this record is not part of another structure,
8360 the current RTYPE length might be good enough for our purposes. */
8361 if (TYPE_LENGTH (type) <= 0)
8362 {
8363 if (TYPE_NAME (rtype))
8364 warning (_("Invalid type size for `%s' detected: %s."),
8365 TYPE_NAME (rtype), pulongest (TYPE_LENGTH (type)));
8366 else
8367 warning (_("Invalid type size for <unnamed> detected: %s."),
8368 pulongest (TYPE_LENGTH (type)));
8369 }
8370 else
8371 {
8372 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8373 TYPE_LENGTH (type));
8374 }
8375
8376 value_free_to_mark (mark);
8377 if (TYPE_LENGTH (rtype) > varsize_limit)
8378 error (_("record type with dynamic size is larger than varsize-limit"));
8379 return rtype;
8380 }
8381
8382 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8383 of 1. */
8384
8385 static struct type *
8386 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8387 CORE_ADDR address, struct value *dval0)
8388 {
8389 return ada_template_to_fixed_record_type_1 (type, valaddr,
8390 address, dval0, 1);
8391 }
8392
8393 /* An ordinary record type in which ___XVL-convention fields and
8394 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8395 static approximations, containing all possible fields. Uses
8396 no runtime values. Useless for use in values, but that's OK,
8397 since the results are used only for type determinations. Works on both
8398 structs and unions. Representation note: to save space, we memorize
8399 the result of this function in the TYPE_TARGET_TYPE of the
8400 template type. */
8401
8402 static struct type *
8403 template_to_static_fixed_type (struct type *type0)
8404 {
8405 struct type *type;
8406 int nfields;
8407 int f;
8408
8409 /* No need no do anything if the input type is already fixed. */
8410 if (TYPE_FIXED_INSTANCE (type0))
8411 return type0;
8412
8413 /* Likewise if we already have computed the static approximation. */
8414 if (TYPE_TARGET_TYPE (type0) != NULL)
8415 return TYPE_TARGET_TYPE (type0);
8416
8417 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8418 type = type0;
8419 nfields = TYPE_NFIELDS (type0);
8420
8421 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8422 recompute all over next time. */
8423 TYPE_TARGET_TYPE (type0) = type;
8424
8425 for (f = 0; f < nfields; f += 1)
8426 {
8427 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
8428 struct type *new_type;
8429
8430 if (is_dynamic_field (type0, f))
8431 {
8432 field_type = ada_check_typedef (field_type);
8433 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8434 }
8435 else
8436 new_type = static_unwrap_type (field_type);
8437
8438 if (new_type != field_type)
8439 {
8440 /* Clone TYPE0 only the first time we get a new field type. */
8441 if (type == type0)
8442 {
8443 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8444 TYPE_CODE (type) = TYPE_CODE (type0);
8445 INIT_NONE_SPECIFIC (type);
8446 TYPE_NFIELDS (type) = nfields;
8447 TYPE_FIELDS (type) = (struct field *)
8448 TYPE_ALLOC (type, nfields * sizeof (struct field));
8449 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8450 sizeof (struct field) * nfields);
8451 TYPE_NAME (type) = ada_type_name (type0);
8452 TYPE_FIXED_INSTANCE (type) = 1;
8453 TYPE_LENGTH (type) = 0;
8454 }
8455 TYPE_FIELD_TYPE (type, f) = new_type;
8456 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8457 }
8458 }
8459
8460 return type;
8461 }
8462
8463 /* Given an object of type TYPE whose contents are at VALADDR and
8464 whose address in memory is ADDRESS, returns a revision of TYPE,
8465 which should be a non-dynamic-sized record, in which the variant
8466 part, if any, is replaced with the appropriate branch. Looks
8467 for discriminant values in DVAL0, which can be NULL if the record
8468 contains the necessary discriminant values. */
8469
8470 static struct type *
8471 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8472 CORE_ADDR address, struct value *dval0)
8473 {
8474 struct value *mark = value_mark ();
8475 struct value *dval;
8476 struct type *rtype;
8477 struct type *branch_type;
8478 int nfields = TYPE_NFIELDS (type);
8479 int variant_field = variant_field_index (type);
8480
8481 if (variant_field == -1)
8482 return type;
8483
8484 if (dval0 == NULL)
8485 {
8486 dval = value_from_contents_and_address (type, valaddr, address);
8487 type = value_type (dval);
8488 }
8489 else
8490 dval = dval0;
8491
8492 rtype = alloc_type_copy (type);
8493 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8494 INIT_NONE_SPECIFIC (rtype);
8495 TYPE_NFIELDS (rtype) = nfields;
8496 TYPE_FIELDS (rtype) =
8497 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8498 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
8499 sizeof (struct field) * nfields);
8500 TYPE_NAME (rtype) = ada_type_name (type);
8501 TYPE_FIXED_INSTANCE (rtype) = 1;
8502 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8503
8504 branch_type = to_fixed_variant_branch_type
8505 (TYPE_FIELD_TYPE (type, variant_field),
8506 cond_offset_host (valaddr,
8507 TYPE_FIELD_BITPOS (type, variant_field)
8508 / TARGET_CHAR_BIT),
8509 cond_offset_target (address,
8510 TYPE_FIELD_BITPOS (type, variant_field)
8511 / TARGET_CHAR_BIT), dval);
8512 if (branch_type == NULL)
8513 {
8514 int f;
8515
8516 for (f = variant_field + 1; f < nfields; f += 1)
8517 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8518 TYPE_NFIELDS (rtype) -= 1;
8519 }
8520 else
8521 {
8522 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8523 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8524 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8525 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
8526 }
8527 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
8528
8529 value_free_to_mark (mark);
8530 return rtype;
8531 }
8532
8533 /* An ordinary record type (with fixed-length fields) that describes
8534 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8535 beginning of this section]. Any necessary discriminants' values
8536 should be in DVAL, a record value; it may be NULL if the object
8537 at ADDR itself contains any necessary discriminant values.
8538 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8539 values from the record are needed. Except in the case that DVAL,
8540 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8541 unchecked) is replaced by a particular branch of the variant.
8542
8543 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8544 is questionable and may be removed. It can arise during the
8545 processing of an unconstrained-array-of-record type where all the
8546 variant branches have exactly the same size. This is because in
8547 such cases, the compiler does not bother to use the XVS convention
8548 when encoding the record. I am currently dubious of this
8549 shortcut and suspect the compiler should be altered. FIXME. */
8550
8551 static struct type *
8552 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8553 CORE_ADDR address, struct value *dval)
8554 {
8555 struct type *templ_type;
8556
8557 if (TYPE_FIXED_INSTANCE (type0))
8558 return type0;
8559
8560 templ_type = dynamic_template_type (type0);
8561
8562 if (templ_type != NULL)
8563 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8564 else if (variant_field_index (type0) >= 0)
8565 {
8566 if (dval == NULL && valaddr == NULL && address == 0)
8567 return type0;
8568 return to_record_with_fixed_variant_part (type0, valaddr, address,
8569 dval);
8570 }
8571 else
8572 {
8573 TYPE_FIXED_INSTANCE (type0) = 1;
8574 return type0;
8575 }
8576
8577 }
8578
8579 /* An ordinary record type (with fixed-length fields) that describes
8580 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8581 union type. Any necessary discriminants' values should be in DVAL,
8582 a record value. That is, this routine selects the appropriate
8583 branch of the union at ADDR according to the discriminant value
8584 indicated in the union's type name. Returns VAR_TYPE0 itself if
8585 it represents a variant subject to a pragma Unchecked_Union. */
8586
8587 static struct type *
8588 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8589 CORE_ADDR address, struct value *dval)
8590 {
8591 int which;
8592 struct type *templ_type;
8593 struct type *var_type;
8594
8595 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8596 var_type = TYPE_TARGET_TYPE (var_type0);
8597 else
8598 var_type = var_type0;
8599
8600 templ_type = ada_find_parallel_type (var_type, "___XVU");
8601
8602 if (templ_type != NULL)
8603 var_type = templ_type;
8604
8605 if (is_unchecked_variant (var_type, value_type (dval)))
8606 return var_type0;
8607 which =
8608 ada_which_variant_applies (var_type,
8609 value_type (dval), value_contents (dval));
8610
8611 if (which < 0)
8612 return empty_record (var_type);
8613 else if (is_dynamic_field (var_type, which))
8614 return to_fixed_record_type
8615 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8616 valaddr, address, dval);
8617 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
8618 return
8619 to_fixed_record_type
8620 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
8621 else
8622 return TYPE_FIELD_TYPE (var_type, which);
8623 }
8624
8625 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8626 ENCODING_TYPE, a type following the GNAT conventions for discrete
8627 type encodings, only carries redundant information. */
8628
8629 static int
8630 ada_is_redundant_range_encoding (struct type *range_type,
8631 struct type *encoding_type)
8632 {
8633 const char *bounds_str;
8634 int n;
8635 LONGEST lo, hi;
8636
8637 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8638
8639 if (TYPE_CODE (get_base_type (range_type))
8640 != TYPE_CODE (get_base_type (encoding_type)))
8641 {
8642 /* The compiler probably used a simple base type to describe
8643 the range type instead of the range's actual base type,
8644 expecting us to get the real base type from the encoding
8645 anyway. In this situation, the encoding cannot be ignored
8646 as redundant. */
8647 return 0;
8648 }
8649
8650 if (is_dynamic_type (range_type))
8651 return 0;
8652
8653 if (TYPE_NAME (encoding_type) == NULL)
8654 return 0;
8655
8656 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8657 if (bounds_str == NULL)
8658 return 0;
8659
8660 n = 8; /* Skip "___XDLU_". */
8661 if (!ada_scan_number (bounds_str, n, &lo, &n))
8662 return 0;
8663 if (TYPE_LOW_BOUND (range_type) != lo)
8664 return 0;
8665
8666 n += 2; /* Skip the "__" separator between the two bounds. */
8667 if (!ada_scan_number (bounds_str, n, &hi, &n))
8668 return 0;
8669 if (TYPE_HIGH_BOUND (range_type) != hi)
8670 return 0;
8671
8672 return 1;
8673 }
8674
8675 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8676 a type following the GNAT encoding for describing array type
8677 indices, only carries redundant information. */
8678
8679 static int
8680 ada_is_redundant_index_type_desc (struct type *array_type,
8681 struct type *desc_type)
8682 {
8683 struct type *this_layer = check_typedef (array_type);
8684 int i;
8685
8686 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8687 {
8688 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8689 TYPE_FIELD_TYPE (desc_type, i)))
8690 return 0;
8691 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8692 }
8693
8694 return 1;
8695 }
8696
8697 /* Assuming that TYPE0 is an array type describing the type of a value
8698 at ADDR, and that DVAL describes a record containing any
8699 discriminants used in TYPE0, returns a type for the value that
8700 contains no dynamic components (that is, no components whose sizes
8701 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8702 true, gives an error message if the resulting type's size is over
8703 varsize_limit. */
8704
8705 static struct type *
8706 to_fixed_array_type (struct type *type0, struct value *dval,
8707 int ignore_too_big)
8708 {
8709 struct type *index_type_desc;
8710 struct type *result;
8711 int constrained_packed_array_p;
8712 static const char *xa_suffix = "___XA";
8713
8714 type0 = ada_check_typedef (type0);
8715 if (TYPE_FIXED_INSTANCE (type0))
8716 return type0;
8717
8718 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8719 if (constrained_packed_array_p)
8720 type0 = decode_constrained_packed_array_type (type0);
8721
8722 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8723
8724 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8725 encoding suffixed with 'P' may still be generated. If so,
8726 it should be used to find the XA type. */
8727
8728 if (index_type_desc == NULL)
8729 {
8730 const char *type_name = ada_type_name (type0);
8731
8732 if (type_name != NULL)
8733 {
8734 const int len = strlen (type_name);
8735 char *name = (char *) alloca (len + strlen (xa_suffix));
8736
8737 if (type_name[len - 1] == 'P')
8738 {
8739 strcpy (name, type_name);
8740 strcpy (name + len - 1, xa_suffix);
8741 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8742 }
8743 }
8744 }
8745
8746 ada_fixup_array_indexes_type (index_type_desc);
8747 if (index_type_desc != NULL
8748 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8749 {
8750 /* Ignore this ___XA parallel type, as it does not bring any
8751 useful information. This allows us to avoid creating fixed
8752 versions of the array's index types, which would be identical
8753 to the original ones. This, in turn, can also help avoid
8754 the creation of fixed versions of the array itself. */
8755 index_type_desc = NULL;
8756 }
8757
8758 if (index_type_desc == NULL)
8759 {
8760 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8761
8762 /* NOTE: elt_type---the fixed version of elt_type0---should never
8763 depend on the contents of the array in properly constructed
8764 debugging data. */
8765 /* Create a fixed version of the array element type.
8766 We're not providing the address of an element here,
8767 and thus the actual object value cannot be inspected to do
8768 the conversion. This should not be a problem, since arrays of
8769 unconstrained objects are not allowed. In particular, all
8770 the elements of an array of a tagged type should all be of
8771 the same type specified in the debugging info. No need to
8772 consult the object tag. */
8773 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8774
8775 /* Make sure we always create a new array type when dealing with
8776 packed array types, since we're going to fix-up the array
8777 type length and element bitsize a little further down. */
8778 if (elt_type0 == elt_type && !constrained_packed_array_p)
8779 result = type0;
8780 else
8781 result = create_array_type (alloc_type_copy (type0),
8782 elt_type, TYPE_INDEX_TYPE (type0));
8783 }
8784 else
8785 {
8786 int i;
8787 struct type *elt_type0;
8788
8789 elt_type0 = type0;
8790 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
8791 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8792
8793 /* NOTE: result---the fixed version of elt_type0---should never
8794 depend on the contents of the array in properly constructed
8795 debugging data. */
8796 /* Create a fixed version of the array element type.
8797 We're not providing the address of an element here,
8798 and thus the actual object value cannot be inspected to do
8799 the conversion. This should not be a problem, since arrays of
8800 unconstrained objects are not allowed. In particular, all
8801 the elements of an array of a tagged type should all be of
8802 the same type specified in the debugging info. No need to
8803 consult the object tag. */
8804 result =
8805 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8806
8807 elt_type0 = type0;
8808 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
8809 {
8810 struct type *range_type =
8811 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
8812
8813 result = create_array_type (alloc_type_copy (elt_type0),
8814 result, range_type);
8815 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8816 }
8817 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
8818 error (_("array type with dynamic size is larger than varsize-limit"));
8819 }
8820
8821 /* We want to preserve the type name. This can be useful when
8822 trying to get the type name of a value that has already been
8823 printed (for instance, if the user did "print VAR; whatis $". */
8824 TYPE_NAME (result) = TYPE_NAME (type0);
8825
8826 if (constrained_packed_array_p)
8827 {
8828 /* So far, the resulting type has been created as if the original
8829 type was a regular (non-packed) array type. As a result, the
8830 bitsize of the array elements needs to be set again, and the array
8831 length needs to be recomputed based on that bitsize. */
8832 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8833 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8834
8835 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8836 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8837 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8838 TYPE_LENGTH (result)++;
8839 }
8840
8841 TYPE_FIXED_INSTANCE (result) = 1;
8842 return result;
8843 }
8844
8845
8846 /* A standard type (containing no dynamically sized components)
8847 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8848 DVAL describes a record containing any discriminants used in TYPE0,
8849 and may be NULL if there are none, or if the object of type TYPE at
8850 ADDRESS or in VALADDR contains these discriminants.
8851
8852 If CHECK_TAG is not null, in the case of tagged types, this function
8853 attempts to locate the object's tag and use it to compute the actual
8854 type. However, when ADDRESS is null, we cannot use it to determine the
8855 location of the tag, and therefore compute the tagged type's actual type.
8856 So we return the tagged type without consulting the tag. */
8857
8858 static struct type *
8859 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8860 CORE_ADDR address, struct value *dval, int check_tag)
8861 {
8862 type = ada_check_typedef (type);
8863
8864 /* Only un-fixed types need to be handled here. */
8865 if (!HAVE_GNAT_AUX_INFO (type))
8866 return type;
8867
8868 switch (TYPE_CODE (type))
8869 {
8870 default:
8871 return type;
8872 case TYPE_CODE_STRUCT:
8873 {
8874 struct type *static_type = to_static_fixed_type (type);
8875 struct type *fixed_record_type =
8876 to_fixed_record_type (type, valaddr, address, NULL);
8877
8878 /* If STATIC_TYPE is a tagged type and we know the object's address,
8879 then we can determine its tag, and compute the object's actual
8880 type from there. Note that we have to use the fixed record
8881 type (the parent part of the record may have dynamic fields
8882 and the way the location of _tag is expressed may depend on
8883 them). */
8884
8885 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8886 {
8887 struct value *tag =
8888 value_tag_from_contents_and_address
8889 (fixed_record_type,
8890 valaddr,
8891 address);
8892 struct type *real_type = type_from_tag (tag);
8893 struct value *obj =
8894 value_from_contents_and_address (fixed_record_type,
8895 valaddr,
8896 address);
8897 fixed_record_type = value_type (obj);
8898 if (real_type != NULL)
8899 return to_fixed_record_type
8900 (real_type, NULL,
8901 value_address (ada_tag_value_at_base_address (obj)), NULL);
8902 }
8903
8904 /* Check to see if there is a parallel ___XVZ variable.
8905 If there is, then it provides the actual size of our type. */
8906 else if (ada_type_name (fixed_record_type) != NULL)
8907 {
8908 const char *name = ada_type_name (fixed_record_type);
8909 char *xvz_name
8910 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8911 bool xvz_found = false;
8912 LONGEST size;
8913
8914 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8915 try
8916 {
8917 xvz_found = get_int_var_value (xvz_name, size);
8918 }
8919 catch (const gdb_exception_error &except)
8920 {
8921 /* We found the variable, but somehow failed to read
8922 its value. Rethrow the same error, but with a little
8923 bit more information, to help the user understand
8924 what went wrong (Eg: the variable might have been
8925 optimized out). */
8926 throw_error (except.error,
8927 _("unable to read value of %s (%s)"),
8928 xvz_name, except.what ());
8929 }
8930
8931 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8932 {
8933 fixed_record_type = copy_type (fixed_record_type);
8934 TYPE_LENGTH (fixed_record_type) = size;
8935
8936 /* The FIXED_RECORD_TYPE may have be a stub. We have
8937 observed this when the debugging info is STABS, and
8938 apparently it is something that is hard to fix.
8939
8940 In practice, we don't need the actual type definition
8941 at all, because the presence of the XVZ variable allows us
8942 to assume that there must be a XVS type as well, which we
8943 should be able to use later, when we need the actual type
8944 definition.
8945
8946 In the meantime, pretend that the "fixed" type we are
8947 returning is NOT a stub, because this can cause trouble
8948 when using this type to create new types targeting it.
8949 Indeed, the associated creation routines often check
8950 whether the target type is a stub and will try to replace
8951 it, thus using a type with the wrong size. This, in turn,
8952 might cause the new type to have the wrong size too.
8953 Consider the case of an array, for instance, where the size
8954 of the array is computed from the number of elements in
8955 our array multiplied by the size of its element. */
8956 TYPE_STUB (fixed_record_type) = 0;
8957 }
8958 }
8959 return fixed_record_type;
8960 }
8961 case TYPE_CODE_ARRAY:
8962 return to_fixed_array_type (type, dval, 1);
8963 case TYPE_CODE_UNION:
8964 if (dval == NULL)
8965 return type;
8966 else
8967 return to_fixed_variant_branch_type (type, valaddr, address, dval);
8968 }
8969 }
8970
8971 /* The same as ada_to_fixed_type_1, except that it preserves the type
8972 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8973
8974 The typedef layer needs be preserved in order to differentiate between
8975 arrays and array pointers when both types are implemented using the same
8976 fat pointer. In the array pointer case, the pointer is encoded as
8977 a typedef of the pointer type. For instance, considering:
8978
8979 type String_Access is access String;
8980 S1 : String_Access := null;
8981
8982 To the debugger, S1 is defined as a typedef of type String. But
8983 to the user, it is a pointer. So if the user tries to print S1,
8984 we should not dereference the array, but print the array address
8985 instead.
8986
8987 If we didn't preserve the typedef layer, we would lose the fact that
8988 the type is to be presented as a pointer (needs de-reference before
8989 being printed). And we would also use the source-level type name. */
8990
8991 struct type *
8992 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8993 CORE_ADDR address, struct value *dval, int check_tag)
8994
8995 {
8996 struct type *fixed_type =
8997 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8998
8999 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9000 then preserve the typedef layer.
9001
9002 Implementation note: We can only check the main-type portion of
9003 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9004 from TYPE now returns a type that has the same instance flags
9005 as TYPE. For instance, if TYPE is a "typedef const", and its
9006 target type is a "struct", then the typedef elimination will return
9007 a "const" version of the target type. See check_typedef for more
9008 details about how the typedef layer elimination is done.
9009
9010 brobecker/2010-11-19: It seems to me that the only case where it is
9011 useful to preserve the typedef layer is when dealing with fat pointers.
9012 Perhaps, we could add a check for that and preserve the typedef layer
9013 only in that situation. But this seems unecessary so far, probably
9014 because we call check_typedef/ada_check_typedef pretty much everywhere.
9015 */
9016 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9017 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
9018 == TYPE_MAIN_TYPE (fixed_type)))
9019 return type;
9020
9021 return fixed_type;
9022 }
9023
9024 /* A standard (static-sized) type corresponding as well as possible to
9025 TYPE0, but based on no runtime data. */
9026
9027 static struct type *
9028 to_static_fixed_type (struct type *type0)
9029 {
9030 struct type *type;
9031
9032 if (type0 == NULL)
9033 return NULL;
9034
9035 if (TYPE_FIXED_INSTANCE (type0))
9036 return type0;
9037
9038 type0 = ada_check_typedef (type0);
9039
9040 switch (TYPE_CODE (type0))
9041 {
9042 default:
9043 return type0;
9044 case TYPE_CODE_STRUCT:
9045 type = dynamic_template_type (type0);
9046 if (type != NULL)
9047 return template_to_static_fixed_type (type);
9048 else
9049 return template_to_static_fixed_type (type0);
9050 case TYPE_CODE_UNION:
9051 type = ada_find_parallel_type (type0, "___XVU");
9052 if (type != NULL)
9053 return template_to_static_fixed_type (type);
9054 else
9055 return template_to_static_fixed_type (type0);
9056 }
9057 }
9058
9059 /* A static approximation of TYPE with all type wrappers removed. */
9060
9061 static struct type *
9062 static_unwrap_type (struct type *type)
9063 {
9064 if (ada_is_aligner_type (type))
9065 {
9066 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
9067 if (ada_type_name (type1) == NULL)
9068 TYPE_NAME (type1) = ada_type_name (type);
9069
9070 return static_unwrap_type (type1);
9071 }
9072 else
9073 {
9074 struct type *raw_real_type = ada_get_base_type (type);
9075
9076 if (raw_real_type == type)
9077 return type;
9078 else
9079 return to_static_fixed_type (raw_real_type);
9080 }
9081 }
9082
9083 /* In some cases, incomplete and private types require
9084 cross-references that are not resolved as records (for example,
9085 type Foo;
9086 type FooP is access Foo;
9087 V: FooP;
9088 type Foo is array ...;
9089 ). In these cases, since there is no mechanism for producing
9090 cross-references to such types, we instead substitute for FooP a
9091 stub enumeration type that is nowhere resolved, and whose tag is
9092 the name of the actual type. Call these types "non-record stubs". */
9093
9094 /* A type equivalent to TYPE that is not a non-record stub, if one
9095 exists, otherwise TYPE. */
9096
9097 struct type *
9098 ada_check_typedef (struct type *type)
9099 {
9100 if (type == NULL)
9101 return NULL;
9102
9103 /* If our type is an access to an unconstrained array, which is encoded
9104 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
9105 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9106 what allows us to distinguish between fat pointers that represent
9107 array types, and fat pointers that represent array access types
9108 (in both cases, the compiler implements them as fat pointers). */
9109 if (ada_is_access_to_unconstrained_array (type))
9110 return type;
9111
9112 type = check_typedef (type);
9113 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
9114 || !TYPE_STUB (type)
9115 || TYPE_NAME (type) == NULL)
9116 return type;
9117 else
9118 {
9119 const char *name = TYPE_NAME (type);
9120 struct type *type1 = ada_find_any_type (name);
9121
9122 if (type1 == NULL)
9123 return type;
9124
9125 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9126 stubs pointing to arrays, as we don't create symbols for array
9127 types, only for the typedef-to-array types). If that's the case,
9128 strip the typedef layer. */
9129 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9130 type1 = ada_check_typedef (type1);
9131
9132 return type1;
9133 }
9134 }
9135
9136 /* A value representing the data at VALADDR/ADDRESS as described by
9137 type TYPE0, but with a standard (static-sized) type that correctly
9138 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9139 type, then return VAL0 [this feature is simply to avoid redundant
9140 creation of struct values]. */
9141
9142 static struct value *
9143 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9144 struct value *val0)
9145 {
9146 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
9147
9148 if (type == type0 && val0 != NULL)
9149 return val0;
9150
9151 if (VALUE_LVAL (val0) != lval_memory)
9152 {
9153 /* Our value does not live in memory; it could be a convenience
9154 variable, for instance. Create a not_lval value using val0's
9155 contents. */
9156 return value_from_contents (type, value_contents (val0));
9157 }
9158
9159 return value_from_contents_and_address (type, 0, address);
9160 }
9161
9162 /* A value representing VAL, but with a standard (static-sized) type
9163 that correctly describes it. Does not necessarily create a new
9164 value. */
9165
9166 struct value *
9167 ada_to_fixed_value (struct value *val)
9168 {
9169 val = unwrap_value (val);
9170 val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
9171 return val;
9172 }
9173 \f
9174
9175 /* Attributes */
9176
9177 /* Table mapping attribute numbers to names.
9178 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
9179
9180 static const char *attribute_names[] = {
9181 "<?>",
9182
9183 "first",
9184 "last",
9185 "length",
9186 "image",
9187 "max",
9188 "min",
9189 "modulus",
9190 "pos",
9191 "size",
9192 "tag",
9193 "val",
9194 0
9195 };
9196
9197 const char *
9198 ada_attribute_name (enum exp_opcode n)
9199 {
9200 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9201 return attribute_names[n - OP_ATR_FIRST + 1];
9202 else
9203 return attribute_names[0];
9204 }
9205
9206 /* Evaluate the 'POS attribute applied to ARG. */
9207
9208 static LONGEST
9209 pos_atr (struct value *arg)
9210 {
9211 struct value *val = coerce_ref (arg);
9212 struct type *type = value_type (val);
9213 LONGEST result;
9214
9215 if (!discrete_type_p (type))
9216 error (_("'POS only defined on discrete types"));
9217
9218 if (!discrete_position (type, value_as_long (val), &result))
9219 error (_("enumeration value is invalid: can't find 'POS"));
9220
9221 return result;
9222 }
9223
9224 static struct value *
9225 value_pos_atr (struct type *type, struct value *arg)
9226 {
9227 return value_from_longest (type, pos_atr (arg));
9228 }
9229
9230 /* Evaluate the TYPE'VAL attribute applied to ARG. */
9231
9232 static struct value *
9233 value_val_atr (struct type *type, struct value *arg)
9234 {
9235 if (!discrete_type_p (type))
9236 error (_("'VAL only defined on discrete types"));
9237 if (!integer_type_p (value_type (arg)))
9238 error (_("'VAL requires integral argument"));
9239
9240 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9241 {
9242 long pos = value_as_long (arg);
9243
9244 if (pos < 0 || pos >= TYPE_NFIELDS (type))
9245 error (_("argument to 'VAL out of range"));
9246 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
9247 }
9248 else
9249 return value_from_longest (type, value_as_long (arg));
9250 }
9251 \f
9252
9253 /* Evaluation */
9254
9255 /* True if TYPE appears to be an Ada character type.
9256 [At the moment, this is true only for Character and Wide_Character;
9257 It is a heuristic test that could stand improvement]. */
9258
9259 bool
9260 ada_is_character_type (struct type *type)
9261 {
9262 const char *name;
9263
9264 /* If the type code says it's a character, then assume it really is,
9265 and don't check any further. */
9266 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9267 return true;
9268
9269 /* Otherwise, assume it's a character type iff it is a discrete type
9270 with a known character type name. */
9271 name = ada_type_name (type);
9272 return (name != NULL
9273 && (TYPE_CODE (type) == TYPE_CODE_INT
9274 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9275 && (strcmp (name, "character") == 0
9276 || strcmp (name, "wide_character") == 0
9277 || strcmp (name, "wide_wide_character") == 0
9278 || strcmp (name, "unsigned char") == 0));
9279 }
9280
9281 /* True if TYPE appears to be an Ada string type. */
9282
9283 bool
9284 ada_is_string_type (struct type *type)
9285 {
9286 type = ada_check_typedef (type);
9287 if (type != NULL
9288 && TYPE_CODE (type) != TYPE_CODE_PTR
9289 && (ada_is_simple_array_type (type)
9290 || ada_is_array_descriptor_type (type))
9291 && ada_array_arity (type) == 1)
9292 {
9293 struct type *elttype = ada_array_element_type (type, 1);
9294
9295 return ada_is_character_type (elttype);
9296 }
9297 else
9298 return false;
9299 }
9300
9301 /* The compiler sometimes provides a parallel XVS type for a given
9302 PAD type. Normally, it is safe to follow the PAD type directly,
9303 but older versions of the compiler have a bug that causes the offset
9304 of its "F" field to be wrong. Following that field in that case
9305 would lead to incorrect results, but this can be worked around
9306 by ignoring the PAD type and using the associated XVS type instead.
9307
9308 Set to True if the debugger should trust the contents of PAD types.
9309 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9310 static int trust_pad_over_xvs = 1;
9311
9312 /* True if TYPE is a struct type introduced by the compiler to force the
9313 alignment of a value. Such types have a single field with a
9314 distinctive name. */
9315
9316 int
9317 ada_is_aligner_type (struct type *type)
9318 {
9319 type = ada_check_typedef (type);
9320
9321 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9322 return 0;
9323
9324 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
9325 && TYPE_NFIELDS (type) == 1
9326 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
9327 }
9328
9329 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9330 the parallel type. */
9331
9332 struct type *
9333 ada_get_base_type (struct type *raw_type)
9334 {
9335 struct type *real_type_namer;
9336 struct type *raw_real_type;
9337
9338 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9339 return raw_type;
9340
9341 if (ada_is_aligner_type (raw_type))
9342 /* The encoding specifies that we should always use the aligner type.
9343 So, even if this aligner type has an associated XVS type, we should
9344 simply ignore it.
9345
9346 According to the compiler gurus, an XVS type parallel to an aligner
9347 type may exist because of a stabs limitation. In stabs, aligner
9348 types are empty because the field has a variable-sized type, and
9349 thus cannot actually be used as an aligner type. As a result,
9350 we need the associated parallel XVS type to decode the type.
9351 Since the policy in the compiler is to not change the internal
9352 representation based on the debugging info format, we sometimes
9353 end up having a redundant XVS type parallel to the aligner type. */
9354 return raw_type;
9355
9356 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9357 if (real_type_namer == NULL
9358 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9359 || TYPE_NFIELDS (real_type_namer) != 1)
9360 return raw_type;
9361
9362 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9363 {
9364 /* This is an older encoding form where the base type needs to be
9365 looked up by name. We prefer the newer enconding because it is
9366 more efficient. */
9367 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9368 if (raw_real_type == NULL)
9369 return raw_type;
9370 else
9371 return raw_real_type;
9372 }
9373
9374 /* The field in our XVS type is a reference to the base type. */
9375 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
9376 }
9377
9378 /* The type of value designated by TYPE, with all aligners removed. */
9379
9380 struct type *
9381 ada_aligned_type (struct type *type)
9382 {
9383 if (ada_is_aligner_type (type))
9384 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9385 else
9386 return ada_get_base_type (type);
9387 }
9388
9389
9390 /* The address of the aligned value in an object at address VALADDR
9391 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9392
9393 const gdb_byte *
9394 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9395 {
9396 if (ada_is_aligner_type (type))
9397 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
9398 valaddr +
9399 TYPE_FIELD_BITPOS (type,
9400 0) / TARGET_CHAR_BIT);
9401 else
9402 return valaddr;
9403 }
9404
9405
9406
9407 /* The printed representation of an enumeration literal with encoded
9408 name NAME. The value is good to the next call of ada_enum_name. */
9409 const char *
9410 ada_enum_name (const char *name)
9411 {
9412 static char *result;
9413 static size_t result_len = 0;
9414 const char *tmp;
9415
9416 /* First, unqualify the enumeration name:
9417 1. Search for the last '.' character. If we find one, then skip
9418 all the preceding characters, the unqualified name starts
9419 right after that dot.
9420 2. Otherwise, we may be debugging on a target where the compiler
9421 translates dots into "__". Search forward for double underscores,
9422 but stop searching when we hit an overloading suffix, which is
9423 of the form "__" followed by digits. */
9424
9425 tmp = strrchr (name, '.');
9426 if (tmp != NULL)
9427 name = tmp + 1;
9428 else
9429 {
9430 while ((tmp = strstr (name, "__")) != NULL)
9431 {
9432 if (isdigit (tmp[2]))
9433 break;
9434 else
9435 name = tmp + 2;
9436 }
9437 }
9438
9439 if (name[0] == 'Q')
9440 {
9441 int v;
9442
9443 if (name[1] == 'U' || name[1] == 'W')
9444 {
9445 if (sscanf (name + 2, "%x", &v) != 1)
9446 return name;
9447 }
9448 else
9449 return name;
9450
9451 GROW_VECT (result, result_len, 16);
9452 if (isascii (v) && isprint (v))
9453 xsnprintf (result, result_len, "'%c'", v);
9454 else if (name[1] == 'U')
9455 xsnprintf (result, result_len, "[\"%02x\"]", v);
9456 else
9457 xsnprintf (result, result_len, "[\"%04x\"]", v);
9458
9459 return result;
9460 }
9461 else
9462 {
9463 tmp = strstr (name, "__");
9464 if (tmp == NULL)
9465 tmp = strstr (name, "$");
9466 if (tmp != NULL)
9467 {
9468 GROW_VECT (result, result_len, tmp - name + 1);
9469 strncpy (result, name, tmp - name);
9470 result[tmp - name] = '\0';
9471 return result;
9472 }
9473
9474 return name;
9475 }
9476 }
9477
9478 /* Evaluate the subexpression of EXP starting at *POS as for
9479 evaluate_type, updating *POS to point just past the evaluated
9480 expression. */
9481
9482 static struct value *
9483 evaluate_subexp_type (struct expression *exp, int *pos)
9484 {
9485 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
9486 }
9487
9488 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9489 value it wraps. */
9490
9491 static struct value *
9492 unwrap_value (struct value *val)
9493 {
9494 struct type *type = ada_check_typedef (value_type (val));
9495
9496 if (ada_is_aligner_type (type))
9497 {
9498 struct value *v = ada_value_struct_elt (val, "F", 0);
9499 struct type *val_type = ada_check_typedef (value_type (v));
9500
9501 if (ada_type_name (val_type) == NULL)
9502 TYPE_NAME (val_type) = ada_type_name (type);
9503
9504 return unwrap_value (v);
9505 }
9506 else
9507 {
9508 struct type *raw_real_type =
9509 ada_check_typedef (ada_get_base_type (type));
9510
9511 /* If there is no parallel XVS or XVE type, then the value is
9512 already unwrapped. Return it without further modification. */
9513 if ((type == raw_real_type)
9514 && ada_find_parallel_type (type, "___XVE") == NULL)
9515 return val;
9516
9517 return
9518 coerce_unspec_val_to_type
9519 (val, ada_to_fixed_type (raw_real_type, 0,
9520 value_address (val),
9521 NULL, 1));
9522 }
9523 }
9524
9525 static struct value *
9526 cast_from_fixed (struct type *type, struct value *arg)
9527 {
9528 struct value *scale = ada_scaling_factor (value_type (arg));
9529 arg = value_cast (value_type (scale), arg);
9530
9531 arg = value_binop (arg, scale, BINOP_MUL);
9532 return value_cast (type, arg);
9533 }
9534
9535 static struct value *
9536 cast_to_fixed (struct type *type, struct value *arg)
9537 {
9538 if (type == value_type (arg))
9539 return arg;
9540
9541 struct value *scale = ada_scaling_factor (type);
9542 if (ada_is_fixed_point_type (value_type (arg)))
9543 arg = cast_from_fixed (value_type (scale), arg);
9544 else
9545 arg = value_cast (value_type (scale), arg);
9546
9547 arg = value_binop (arg, scale, BINOP_DIV);
9548 return value_cast (type, arg);
9549 }
9550
9551 /* Given two array types T1 and T2, return nonzero iff both arrays
9552 contain the same number of elements. */
9553
9554 static int
9555 ada_same_array_size_p (struct type *t1, struct type *t2)
9556 {
9557 LONGEST lo1, hi1, lo2, hi2;
9558
9559 /* Get the array bounds in order to verify that the size of
9560 the two arrays match. */
9561 if (!get_array_bounds (t1, &lo1, &hi1)
9562 || !get_array_bounds (t2, &lo2, &hi2))
9563 error (_("unable to determine array bounds"));
9564
9565 /* To make things easier for size comparison, normalize a bit
9566 the case of empty arrays by making sure that the difference
9567 between upper bound and lower bound is always -1. */
9568 if (lo1 > hi1)
9569 hi1 = lo1 - 1;
9570 if (lo2 > hi2)
9571 hi2 = lo2 - 1;
9572
9573 return (hi1 - lo1 == hi2 - lo2);
9574 }
9575
9576 /* Assuming that VAL is an array of integrals, and TYPE represents
9577 an array with the same number of elements, but with wider integral
9578 elements, return an array "casted" to TYPE. In practice, this
9579 means that the returned array is built by casting each element
9580 of the original array into TYPE's (wider) element type. */
9581
9582 static struct value *
9583 ada_promote_array_of_integrals (struct type *type, struct value *val)
9584 {
9585 struct type *elt_type = TYPE_TARGET_TYPE (type);
9586 LONGEST lo, hi;
9587 struct value *res;
9588 LONGEST i;
9589
9590 /* Verify that both val and type are arrays of scalars, and
9591 that the size of val's elements is smaller than the size
9592 of type's element. */
9593 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9594 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9595 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9596 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9597 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9598 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9599
9600 if (!get_array_bounds (type, &lo, &hi))
9601 error (_("unable to determine array bounds"));
9602
9603 res = allocate_value (type);
9604
9605 /* Promote each array element. */
9606 for (i = 0; i < hi - lo + 1; i++)
9607 {
9608 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9609
9610 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9611 value_contents_all (elt), TYPE_LENGTH (elt_type));
9612 }
9613
9614 return res;
9615 }
9616
9617 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9618 return the converted value. */
9619
9620 static struct value *
9621 coerce_for_assign (struct type *type, struct value *val)
9622 {
9623 struct type *type2 = value_type (val);
9624
9625 if (type == type2)
9626 return val;
9627
9628 type2 = ada_check_typedef (type2);
9629 type = ada_check_typedef (type);
9630
9631 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9632 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9633 {
9634 val = ada_value_ind (val);
9635 type2 = value_type (val);
9636 }
9637
9638 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
9639 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9640 {
9641 if (!ada_same_array_size_p (type, type2))
9642 error (_("cannot assign arrays of different length"));
9643
9644 if (is_integral_type (TYPE_TARGET_TYPE (type))
9645 && is_integral_type (TYPE_TARGET_TYPE (type2))
9646 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9647 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9648 {
9649 /* Allow implicit promotion of the array elements to
9650 a wider type. */
9651 return ada_promote_array_of_integrals (type, val);
9652 }
9653
9654 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9655 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9656 error (_("Incompatible types in assignment"));
9657 deprecated_set_value_type (val, type);
9658 }
9659 return val;
9660 }
9661
9662 static struct value *
9663 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9664 {
9665 struct value *val;
9666 struct type *type1, *type2;
9667 LONGEST v, v1, v2;
9668
9669 arg1 = coerce_ref (arg1);
9670 arg2 = coerce_ref (arg2);
9671 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9672 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9673
9674 if (TYPE_CODE (type1) != TYPE_CODE_INT
9675 || TYPE_CODE (type2) != TYPE_CODE_INT)
9676 return value_binop (arg1, arg2, op);
9677
9678 switch (op)
9679 {
9680 case BINOP_MOD:
9681 case BINOP_DIV:
9682 case BINOP_REM:
9683 break;
9684 default:
9685 return value_binop (arg1, arg2, op);
9686 }
9687
9688 v2 = value_as_long (arg2);
9689 if (v2 == 0)
9690 error (_("second operand of %s must not be zero."), op_string (op));
9691
9692 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9693 return value_binop (arg1, arg2, op);
9694
9695 v1 = value_as_long (arg1);
9696 switch (op)
9697 {
9698 case BINOP_DIV:
9699 v = v1 / v2;
9700 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9701 v += v > 0 ? -1 : 1;
9702 break;
9703 case BINOP_REM:
9704 v = v1 % v2;
9705 if (v * v1 < 0)
9706 v -= v2;
9707 break;
9708 default:
9709 /* Should not reach this point. */
9710 v = 0;
9711 }
9712
9713 val = allocate_value (type1);
9714 store_unsigned_integer (value_contents_raw (val),
9715 TYPE_LENGTH (value_type (val)),
9716 gdbarch_byte_order (get_type_arch (type1)), v);
9717 return val;
9718 }
9719
9720 static int
9721 ada_value_equal (struct value *arg1, struct value *arg2)
9722 {
9723 if (ada_is_direct_array_type (value_type (arg1))
9724 || ada_is_direct_array_type (value_type (arg2)))
9725 {
9726 struct type *arg1_type, *arg2_type;
9727
9728 /* Automatically dereference any array reference before
9729 we attempt to perform the comparison. */
9730 arg1 = ada_coerce_ref (arg1);
9731 arg2 = ada_coerce_ref (arg2);
9732
9733 arg1 = ada_coerce_to_simple_array (arg1);
9734 arg2 = ada_coerce_to_simple_array (arg2);
9735
9736 arg1_type = ada_check_typedef (value_type (arg1));
9737 arg2_type = ada_check_typedef (value_type (arg2));
9738
9739 if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY
9740 || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY)
9741 error (_("Attempt to compare array with non-array"));
9742 /* FIXME: The following works only for types whose
9743 representations use all bits (no padding or undefined bits)
9744 and do not have user-defined equality. */
9745 return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9746 && memcmp (value_contents (arg1), value_contents (arg2),
9747 TYPE_LENGTH (arg1_type)) == 0);
9748 }
9749 return value_equal (arg1, arg2);
9750 }
9751
9752 /* Total number of component associations in the aggregate starting at
9753 index PC in EXP. Assumes that index PC is the start of an
9754 OP_AGGREGATE. */
9755
9756 static int
9757 num_component_specs (struct expression *exp, int pc)
9758 {
9759 int n, m, i;
9760
9761 m = exp->elts[pc + 1].longconst;
9762 pc += 3;
9763 n = 0;
9764 for (i = 0; i < m; i += 1)
9765 {
9766 switch (exp->elts[pc].opcode)
9767 {
9768 default:
9769 n += 1;
9770 break;
9771 case OP_CHOICES:
9772 n += exp->elts[pc + 1].longconst;
9773 break;
9774 }
9775 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9776 }
9777 return n;
9778 }
9779
9780 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9781 component of LHS (a simple array or a record), updating *POS past
9782 the expression, assuming that LHS is contained in CONTAINER. Does
9783 not modify the inferior's memory, nor does it modify LHS (unless
9784 LHS == CONTAINER). */
9785
9786 static void
9787 assign_component (struct value *container, struct value *lhs, LONGEST index,
9788 struct expression *exp, int *pos)
9789 {
9790 struct value *mark = value_mark ();
9791 struct value *elt;
9792 struct type *lhs_type = check_typedef (value_type (lhs));
9793
9794 if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY)
9795 {
9796 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9797 struct value *index_val = value_from_longest (index_type, index);
9798
9799 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9800 }
9801 else
9802 {
9803 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9804 elt = ada_to_fixed_value (elt);
9805 }
9806
9807 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9808 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9809 else
9810 value_assign_to_component (container, elt,
9811 ada_evaluate_subexp (NULL, exp, pos,
9812 EVAL_NORMAL));
9813
9814 value_free_to_mark (mark);
9815 }
9816
9817 /* Assuming that LHS represents an lvalue having a record or array
9818 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9819 of that aggregate's value to LHS, advancing *POS past the
9820 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9821 lvalue containing LHS (possibly LHS itself). Does not modify
9822 the inferior's memory, nor does it modify the contents of
9823 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9824
9825 static struct value *
9826 assign_aggregate (struct value *container,
9827 struct value *lhs, struct expression *exp,
9828 int *pos, enum noside noside)
9829 {
9830 struct type *lhs_type;
9831 int n = exp->elts[*pos+1].longconst;
9832 LONGEST low_index, high_index;
9833 int num_specs;
9834 LONGEST *indices;
9835 int max_indices, num_indices;
9836 int i;
9837
9838 *pos += 3;
9839 if (noside != EVAL_NORMAL)
9840 {
9841 for (i = 0; i < n; i += 1)
9842 ada_evaluate_subexp (NULL, exp, pos, noside);
9843 return container;
9844 }
9845
9846 container = ada_coerce_ref (container);
9847 if (ada_is_direct_array_type (value_type (container)))
9848 container = ada_coerce_to_simple_array (container);
9849 lhs = ada_coerce_ref (lhs);
9850 if (!deprecated_value_modifiable (lhs))
9851 error (_("Left operand of assignment is not a modifiable lvalue."));
9852
9853 lhs_type = check_typedef (value_type (lhs));
9854 if (ada_is_direct_array_type (lhs_type))
9855 {
9856 lhs = ada_coerce_to_simple_array (lhs);
9857 lhs_type = check_typedef (value_type (lhs));
9858 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9859 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
9860 }
9861 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9862 {
9863 low_index = 0;
9864 high_index = num_visible_fields (lhs_type) - 1;
9865 }
9866 else
9867 error (_("Left-hand side must be array or record."));
9868
9869 num_specs = num_component_specs (exp, *pos - 3);
9870 max_indices = 4 * num_specs + 4;
9871 indices = XALLOCAVEC (LONGEST, max_indices);
9872 indices[0] = indices[1] = low_index - 1;
9873 indices[2] = indices[3] = high_index + 1;
9874 num_indices = 4;
9875
9876 for (i = 0; i < n; i += 1)
9877 {
9878 switch (exp->elts[*pos].opcode)
9879 {
9880 case OP_CHOICES:
9881 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9882 &num_indices, max_indices,
9883 low_index, high_index);
9884 break;
9885 case OP_POSITIONAL:
9886 aggregate_assign_positional (container, lhs, exp, pos, indices,
9887 &num_indices, max_indices,
9888 low_index, high_index);
9889 break;
9890 case OP_OTHERS:
9891 if (i != n-1)
9892 error (_("Misplaced 'others' clause"));
9893 aggregate_assign_others (container, lhs, exp, pos, indices,
9894 num_indices, low_index, high_index);
9895 break;
9896 default:
9897 error (_("Internal error: bad aggregate clause"));
9898 }
9899 }
9900
9901 return container;
9902 }
9903
9904 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9905 construct at *POS, updating *POS past the construct, given that
9906 the positions are relative to lower bound LOW, where HIGH is the
9907 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9908 updating *NUM_INDICES as needed. CONTAINER is as for
9909 assign_aggregate. */
9910 static void
9911 aggregate_assign_positional (struct value *container,
9912 struct value *lhs, struct expression *exp,
9913 int *pos, LONGEST *indices, int *num_indices,
9914 int max_indices, LONGEST low, LONGEST high)
9915 {
9916 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9917
9918 if (ind - 1 == high)
9919 warning (_("Extra components in aggregate ignored."));
9920 if (ind <= high)
9921 {
9922 add_component_interval (ind, ind, indices, num_indices, max_indices);
9923 *pos += 3;
9924 assign_component (container, lhs, ind, exp, pos);
9925 }
9926 else
9927 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9928 }
9929
9930 /* Assign into the components of LHS indexed by the OP_CHOICES
9931 construct at *POS, updating *POS past the construct, given that
9932 the allowable indices are LOW..HIGH. Record the indices assigned
9933 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9934 needed. CONTAINER is as for assign_aggregate. */
9935 static void
9936 aggregate_assign_from_choices (struct value *container,
9937 struct value *lhs, struct expression *exp,
9938 int *pos, LONGEST *indices, int *num_indices,
9939 int max_indices, LONGEST low, LONGEST high)
9940 {
9941 int j;
9942 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9943 int choice_pos, expr_pc;
9944 int is_array = ada_is_direct_array_type (value_type (lhs));
9945
9946 choice_pos = *pos += 3;
9947
9948 for (j = 0; j < n_choices; j += 1)
9949 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9950 expr_pc = *pos;
9951 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9952
9953 for (j = 0; j < n_choices; j += 1)
9954 {
9955 LONGEST lower, upper;
9956 enum exp_opcode op = exp->elts[choice_pos].opcode;
9957
9958 if (op == OP_DISCRETE_RANGE)
9959 {
9960 choice_pos += 1;
9961 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9962 EVAL_NORMAL));
9963 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9964 EVAL_NORMAL));
9965 }
9966 else if (is_array)
9967 {
9968 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9969 EVAL_NORMAL));
9970 upper = lower;
9971 }
9972 else
9973 {
9974 int ind;
9975 const char *name;
9976
9977 switch (op)
9978 {
9979 case OP_NAME:
9980 name = &exp->elts[choice_pos + 2].string;
9981 break;
9982 case OP_VAR_VALUE:
9983 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9984 break;
9985 default:
9986 error (_("Invalid record component association."));
9987 }
9988 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9989 ind = 0;
9990 if (! find_struct_field (name, value_type (lhs), 0,
9991 NULL, NULL, NULL, NULL, &ind))
9992 error (_("Unknown component name: %s."), name);
9993 lower = upper = ind;
9994 }
9995
9996 if (lower <= upper && (lower < low || upper > high))
9997 error (_("Index in component association out of bounds."));
9998
9999 add_component_interval (lower, upper, indices, num_indices,
10000 max_indices);
10001 while (lower <= upper)
10002 {
10003 int pos1;
10004
10005 pos1 = expr_pc;
10006 assign_component (container, lhs, lower, exp, &pos1);
10007 lower += 1;
10008 }
10009 }
10010 }
10011
10012 /* Assign the value of the expression in the OP_OTHERS construct in
10013 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10014 have not been previously assigned. The index intervals already assigned
10015 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
10016 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
10017 static void
10018 aggregate_assign_others (struct value *container,
10019 struct value *lhs, struct expression *exp,
10020 int *pos, LONGEST *indices, int num_indices,
10021 LONGEST low, LONGEST high)
10022 {
10023 int i;
10024 int expr_pc = *pos + 1;
10025
10026 for (i = 0; i < num_indices - 2; i += 2)
10027 {
10028 LONGEST ind;
10029
10030 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10031 {
10032 int localpos;
10033
10034 localpos = expr_pc;
10035 assign_component (container, lhs, ind, exp, &localpos);
10036 }
10037 }
10038 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10039 }
10040
10041 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
10042 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10043 modifying *SIZE as needed. It is an error if *SIZE exceeds
10044 MAX_SIZE. The resulting intervals do not overlap. */
10045 static void
10046 add_component_interval (LONGEST low, LONGEST high,
10047 LONGEST* indices, int *size, int max_size)
10048 {
10049 int i, j;
10050
10051 for (i = 0; i < *size; i += 2) {
10052 if (high >= indices[i] && low <= indices[i + 1])
10053 {
10054 int kh;
10055
10056 for (kh = i + 2; kh < *size; kh += 2)
10057 if (high < indices[kh])
10058 break;
10059 if (low < indices[i])
10060 indices[i] = low;
10061 indices[i + 1] = indices[kh - 1];
10062 if (high > indices[i + 1])
10063 indices[i + 1] = high;
10064 memcpy (indices + i + 2, indices + kh, *size - kh);
10065 *size -= kh - i - 2;
10066 return;
10067 }
10068 else if (high < indices[i])
10069 break;
10070 }
10071
10072 if (*size == max_size)
10073 error (_("Internal error: miscounted aggregate components."));
10074 *size += 2;
10075 for (j = *size-1; j >= i+2; j -= 1)
10076 indices[j] = indices[j - 2];
10077 indices[i] = low;
10078 indices[i + 1] = high;
10079 }
10080
10081 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10082 is different. */
10083
10084 static struct value *
10085 ada_value_cast (struct type *type, struct value *arg2)
10086 {
10087 if (type == ada_check_typedef (value_type (arg2)))
10088 return arg2;
10089
10090 if (ada_is_fixed_point_type (type))
10091 return cast_to_fixed (type, arg2);
10092
10093 if (ada_is_fixed_point_type (value_type (arg2)))
10094 return cast_from_fixed (type, arg2);
10095
10096 return value_cast (type, arg2);
10097 }
10098
10099 /* Evaluating Ada expressions, and printing their result.
10100 ------------------------------------------------------
10101
10102 1. Introduction:
10103 ----------------
10104
10105 We usually evaluate an Ada expression in order to print its value.
10106 We also evaluate an expression in order to print its type, which
10107 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10108 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10109 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10110 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10111 similar.
10112
10113 Evaluating expressions is a little more complicated for Ada entities
10114 than it is for entities in languages such as C. The main reason for
10115 this is that Ada provides types whose definition might be dynamic.
10116 One example of such types is variant records. Or another example
10117 would be an array whose bounds can only be known at run time.
10118
10119 The following description is a general guide as to what should be
10120 done (and what should NOT be done) in order to evaluate an expression
10121 involving such types, and when. This does not cover how the semantic
10122 information is encoded by GNAT as this is covered separatly. For the
10123 document used as the reference for the GNAT encoding, see exp_dbug.ads
10124 in the GNAT sources.
10125
10126 Ideally, we should embed each part of this description next to its
10127 associated code. Unfortunately, the amount of code is so vast right
10128 now that it's hard to see whether the code handling a particular
10129 situation might be duplicated or not. One day, when the code is
10130 cleaned up, this guide might become redundant with the comments
10131 inserted in the code, and we might want to remove it.
10132
10133 2. ``Fixing'' an Entity, the Simple Case:
10134 -----------------------------------------
10135
10136 When evaluating Ada expressions, the tricky issue is that they may
10137 reference entities whose type contents and size are not statically
10138 known. Consider for instance a variant record:
10139
10140 type Rec (Empty : Boolean := True) is record
10141 case Empty is
10142 when True => null;
10143 when False => Value : Integer;
10144 end case;
10145 end record;
10146 Yes : Rec := (Empty => False, Value => 1);
10147 No : Rec := (empty => True);
10148
10149 The size and contents of that record depends on the value of the
10150 descriminant (Rec.Empty). At this point, neither the debugging
10151 information nor the associated type structure in GDB are able to
10152 express such dynamic types. So what the debugger does is to create
10153 "fixed" versions of the type that applies to the specific object.
10154 We also informally refer to this opperation as "fixing" an object,
10155 which means creating its associated fixed type.
10156
10157 Example: when printing the value of variable "Yes" above, its fixed
10158 type would look like this:
10159
10160 type Rec is record
10161 Empty : Boolean;
10162 Value : Integer;
10163 end record;
10164
10165 On the other hand, if we printed the value of "No", its fixed type
10166 would become:
10167
10168 type Rec is record
10169 Empty : Boolean;
10170 end record;
10171
10172 Things become a little more complicated when trying to fix an entity
10173 with a dynamic type that directly contains another dynamic type,
10174 such as an array of variant records, for instance. There are
10175 two possible cases: Arrays, and records.
10176
10177 3. ``Fixing'' Arrays:
10178 ---------------------
10179
10180 The type structure in GDB describes an array in terms of its bounds,
10181 and the type of its elements. By design, all elements in the array
10182 have the same type and we cannot represent an array of variant elements
10183 using the current type structure in GDB. When fixing an array,
10184 we cannot fix the array element, as we would potentially need one
10185 fixed type per element of the array. As a result, the best we can do
10186 when fixing an array is to produce an array whose bounds and size
10187 are correct (allowing us to read it from memory), but without having
10188 touched its element type. Fixing each element will be done later,
10189 when (if) necessary.
10190
10191 Arrays are a little simpler to handle than records, because the same
10192 amount of memory is allocated for each element of the array, even if
10193 the amount of space actually used by each element differs from element
10194 to element. Consider for instance the following array of type Rec:
10195
10196 type Rec_Array is array (1 .. 2) of Rec;
10197
10198 The actual amount of memory occupied by each element might be different
10199 from element to element, depending on the value of their discriminant.
10200 But the amount of space reserved for each element in the array remains
10201 fixed regardless. So we simply need to compute that size using
10202 the debugging information available, from which we can then determine
10203 the array size (we multiply the number of elements of the array by
10204 the size of each element).
10205
10206 The simplest case is when we have an array of a constrained element
10207 type. For instance, consider the following type declarations:
10208
10209 type Bounded_String (Max_Size : Integer) is
10210 Length : Integer;
10211 Buffer : String (1 .. Max_Size);
10212 end record;
10213 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10214
10215 In this case, the compiler describes the array as an array of
10216 variable-size elements (identified by its XVS suffix) for which
10217 the size can be read in the parallel XVZ variable.
10218
10219 In the case of an array of an unconstrained element type, the compiler
10220 wraps the array element inside a private PAD type. This type should not
10221 be shown to the user, and must be "unwrap"'ed before printing. Note
10222 that we also use the adjective "aligner" in our code to designate
10223 these wrapper types.
10224
10225 In some cases, the size allocated for each element is statically
10226 known. In that case, the PAD type already has the correct size,
10227 and the array element should remain unfixed.
10228
10229 But there are cases when this size is not statically known.
10230 For instance, assuming that "Five" is an integer variable:
10231
10232 type Dynamic is array (1 .. Five) of Integer;
10233 type Wrapper (Has_Length : Boolean := False) is record
10234 Data : Dynamic;
10235 case Has_Length is
10236 when True => Length : Integer;
10237 when False => null;
10238 end case;
10239 end record;
10240 type Wrapper_Array is array (1 .. 2) of Wrapper;
10241
10242 Hello : Wrapper_Array := (others => (Has_Length => True,
10243 Data => (others => 17),
10244 Length => 1));
10245
10246
10247 The debugging info would describe variable Hello as being an
10248 array of a PAD type. The size of that PAD type is not statically
10249 known, but can be determined using a parallel XVZ variable.
10250 In that case, a copy of the PAD type with the correct size should
10251 be used for the fixed array.
10252
10253 3. ``Fixing'' record type objects:
10254 ----------------------------------
10255
10256 Things are slightly different from arrays in the case of dynamic
10257 record types. In this case, in order to compute the associated
10258 fixed type, we need to determine the size and offset of each of
10259 its components. This, in turn, requires us to compute the fixed
10260 type of each of these components.
10261
10262 Consider for instance the example:
10263
10264 type Bounded_String (Max_Size : Natural) is record
10265 Str : String (1 .. Max_Size);
10266 Length : Natural;
10267 end record;
10268 My_String : Bounded_String (Max_Size => 10);
10269
10270 In that case, the position of field "Length" depends on the size
10271 of field Str, which itself depends on the value of the Max_Size
10272 discriminant. In order to fix the type of variable My_String,
10273 we need to fix the type of field Str. Therefore, fixing a variant
10274 record requires us to fix each of its components.
10275
10276 However, if a component does not have a dynamic size, the component
10277 should not be fixed. In particular, fields that use a PAD type
10278 should not fixed. Here is an example where this might happen
10279 (assuming type Rec above):
10280
10281 type Container (Big : Boolean) is record
10282 First : Rec;
10283 After : Integer;
10284 case Big is
10285 when True => Another : Integer;
10286 when False => null;
10287 end case;
10288 end record;
10289 My_Container : Container := (Big => False,
10290 First => (Empty => True),
10291 After => 42);
10292
10293 In that example, the compiler creates a PAD type for component First,
10294 whose size is constant, and then positions the component After just
10295 right after it. The offset of component After is therefore constant
10296 in this case.
10297
10298 The debugger computes the position of each field based on an algorithm
10299 that uses, among other things, the actual position and size of the field
10300 preceding it. Let's now imagine that the user is trying to print
10301 the value of My_Container. If the type fixing was recursive, we would
10302 end up computing the offset of field After based on the size of the
10303 fixed version of field First. And since in our example First has
10304 only one actual field, the size of the fixed type is actually smaller
10305 than the amount of space allocated to that field, and thus we would
10306 compute the wrong offset of field After.
10307
10308 To make things more complicated, we need to watch out for dynamic
10309 components of variant records (identified by the ___XVL suffix in
10310 the component name). Even if the target type is a PAD type, the size
10311 of that type might not be statically known. So the PAD type needs
10312 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10313 we might end up with the wrong size for our component. This can be
10314 observed with the following type declarations:
10315
10316 type Octal is new Integer range 0 .. 7;
10317 type Octal_Array is array (Positive range <>) of Octal;
10318 pragma Pack (Octal_Array);
10319
10320 type Octal_Buffer (Size : Positive) is record
10321 Buffer : Octal_Array (1 .. Size);
10322 Length : Integer;
10323 end record;
10324
10325 In that case, Buffer is a PAD type whose size is unset and needs
10326 to be computed by fixing the unwrapped type.
10327
10328 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10329 ----------------------------------------------------------
10330
10331 Lastly, when should the sub-elements of an entity that remained unfixed
10332 thus far, be actually fixed?
10333
10334 The answer is: Only when referencing that element. For instance
10335 when selecting one component of a record, this specific component
10336 should be fixed at that point in time. Or when printing the value
10337 of a record, each component should be fixed before its value gets
10338 printed. Similarly for arrays, the element of the array should be
10339 fixed when printing each element of the array, or when extracting
10340 one element out of that array. On the other hand, fixing should
10341 not be performed on the elements when taking a slice of an array!
10342
10343 Note that one of the side effects of miscomputing the offset and
10344 size of each field is that we end up also miscomputing the size
10345 of the containing type. This can have adverse results when computing
10346 the value of an entity. GDB fetches the value of an entity based
10347 on the size of its type, and thus a wrong size causes GDB to fetch
10348 the wrong amount of memory. In the case where the computed size is
10349 too small, GDB fetches too little data to print the value of our
10350 entity. Results in this case are unpredictable, as we usually read
10351 past the buffer containing the data =:-o. */
10352
10353 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10354 for that subexpression cast to TO_TYPE. Advance *POS over the
10355 subexpression. */
10356
10357 static value *
10358 ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10359 enum noside noside, struct type *to_type)
10360 {
10361 int pc = *pos;
10362
10363 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10364 || exp->elts[pc].opcode == OP_VAR_VALUE)
10365 {
10366 (*pos) += 4;
10367
10368 value *val;
10369 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10370 {
10371 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10372 return value_zero (to_type, not_lval);
10373
10374 val = evaluate_var_msym_value (noside,
10375 exp->elts[pc + 1].objfile,
10376 exp->elts[pc + 2].msymbol);
10377 }
10378 else
10379 val = evaluate_var_value (noside,
10380 exp->elts[pc + 1].block,
10381 exp->elts[pc + 2].symbol);
10382
10383 if (noside == EVAL_SKIP)
10384 return eval_skip_value (exp);
10385
10386 val = ada_value_cast (to_type, val);
10387
10388 /* Follow the Ada language semantics that do not allow taking
10389 an address of the result of a cast (view conversion in Ada). */
10390 if (VALUE_LVAL (val) == lval_memory)
10391 {
10392 if (value_lazy (val))
10393 value_fetch_lazy (val);
10394 VALUE_LVAL (val) = not_lval;
10395 }
10396 return val;
10397 }
10398
10399 value *val = evaluate_subexp (to_type, exp, pos, noside);
10400 if (noside == EVAL_SKIP)
10401 return eval_skip_value (exp);
10402 return ada_value_cast (to_type, val);
10403 }
10404
10405 /* Implement the evaluate_exp routine in the exp_descriptor structure
10406 for the Ada language. */
10407
10408 static struct value *
10409 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
10410 int *pos, enum noside noside)
10411 {
10412 enum exp_opcode op;
10413 int tem;
10414 int pc;
10415 int preeval_pos;
10416 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10417 struct type *type;
10418 int nargs, oplen;
10419 struct value **argvec;
10420
10421 pc = *pos;
10422 *pos += 1;
10423 op = exp->elts[pc].opcode;
10424
10425 switch (op)
10426 {
10427 default:
10428 *pos -= 1;
10429 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10430
10431 if (noside == EVAL_NORMAL)
10432 arg1 = unwrap_value (arg1);
10433
10434 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10435 then we need to perform the conversion manually, because
10436 evaluate_subexp_standard doesn't do it. This conversion is
10437 necessary in Ada because the different kinds of float/fixed
10438 types in Ada have different representations.
10439
10440 Similarly, we need to perform the conversion from OP_LONG
10441 ourselves. */
10442 if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
10443 arg1 = ada_value_cast (expect_type, arg1);
10444
10445 return arg1;
10446
10447 case OP_STRING:
10448 {
10449 struct value *result;
10450
10451 *pos -= 1;
10452 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10453 /* The result type will have code OP_STRING, bashed there from
10454 OP_ARRAY. Bash it back. */
10455 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10456 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
10457 return result;
10458 }
10459
10460 case UNOP_CAST:
10461 (*pos) += 2;
10462 type = exp->elts[pc + 1].type;
10463 return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
10464
10465 case UNOP_QUAL:
10466 (*pos) += 2;
10467 type = exp->elts[pc + 1].type;
10468 return ada_evaluate_subexp (type, exp, pos, noside);
10469
10470 case BINOP_ASSIGN:
10471 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10472 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10473 {
10474 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10475 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10476 return arg1;
10477 return ada_value_assign (arg1, arg1);
10478 }
10479 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10480 except if the lhs of our assignment is a convenience variable.
10481 In the case of assigning to a convenience variable, the lhs
10482 should be exactly the result of the evaluation of the rhs. */
10483 type = value_type (arg1);
10484 if (VALUE_LVAL (arg1) == lval_internalvar)
10485 type = NULL;
10486 arg2 = evaluate_subexp (type, exp, pos, noside);
10487 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10488 return arg1;
10489 if (VALUE_LVAL (arg1) == lval_internalvar)
10490 {
10491 /* Nothing. */
10492 }
10493 else if (ada_is_fixed_point_type (value_type (arg1)))
10494 arg2 = cast_to_fixed (value_type (arg1), arg2);
10495 else if (ada_is_fixed_point_type (value_type (arg2)))
10496 error
10497 (_("Fixed-point values must be assigned to fixed-point variables"));
10498 else
10499 arg2 = coerce_for_assign (value_type (arg1), arg2);
10500 return ada_value_assign (arg1, arg2);
10501
10502 case BINOP_ADD:
10503 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10504 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10505 if (noside == EVAL_SKIP)
10506 goto nosideret;
10507 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10508 return (value_from_longest
10509 (value_type (arg1),
10510 value_as_long (arg1) + value_as_long (arg2)));
10511 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10512 return (value_from_longest
10513 (value_type (arg2),
10514 value_as_long (arg1) + value_as_long (arg2)));
10515 if ((ada_is_fixed_point_type (value_type (arg1))
10516 || ada_is_fixed_point_type (value_type (arg2)))
10517 && value_type (arg1) != value_type (arg2))
10518 error (_("Operands of fixed-point addition must have the same type"));
10519 /* Do the addition, and cast the result to the type of the first
10520 argument. We cannot cast the result to a reference type, so if
10521 ARG1 is a reference type, find its underlying type. */
10522 type = value_type (arg1);
10523 while (TYPE_CODE (type) == TYPE_CODE_REF)
10524 type = TYPE_TARGET_TYPE (type);
10525 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10526 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
10527
10528 case BINOP_SUB:
10529 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10530 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10531 if (noside == EVAL_SKIP)
10532 goto nosideret;
10533 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10534 return (value_from_longest
10535 (value_type (arg1),
10536 value_as_long (arg1) - value_as_long (arg2)));
10537 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10538 return (value_from_longest
10539 (value_type (arg2),
10540 value_as_long (arg1) - value_as_long (arg2)));
10541 if ((ada_is_fixed_point_type (value_type (arg1))
10542 || ada_is_fixed_point_type (value_type (arg2)))
10543 && value_type (arg1) != value_type (arg2))
10544 error (_("Operands of fixed-point subtraction "
10545 "must have the same type"));
10546 /* Do the substraction, and cast the result to the type of the first
10547 argument. We cannot cast the result to a reference type, so if
10548 ARG1 is a reference type, find its underlying type. */
10549 type = value_type (arg1);
10550 while (TYPE_CODE (type) == TYPE_CODE_REF)
10551 type = TYPE_TARGET_TYPE (type);
10552 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10553 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
10554
10555 case BINOP_MUL:
10556 case BINOP_DIV:
10557 case BINOP_REM:
10558 case BINOP_MOD:
10559 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10560 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10561 if (noside == EVAL_SKIP)
10562 goto nosideret;
10563 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10564 {
10565 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10566 return value_zero (value_type (arg1), not_lval);
10567 }
10568 else
10569 {
10570 type = builtin_type (exp->gdbarch)->builtin_double;
10571 if (ada_is_fixed_point_type (value_type (arg1)))
10572 arg1 = cast_from_fixed (type, arg1);
10573 if (ada_is_fixed_point_type (value_type (arg2)))
10574 arg2 = cast_from_fixed (type, arg2);
10575 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10576 return ada_value_binop (arg1, arg2, op);
10577 }
10578
10579 case BINOP_EQUAL:
10580 case BINOP_NOTEQUAL:
10581 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10582 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
10583 if (noside == EVAL_SKIP)
10584 goto nosideret;
10585 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10586 tem = 0;
10587 else
10588 {
10589 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10590 tem = ada_value_equal (arg1, arg2);
10591 }
10592 if (op == BINOP_NOTEQUAL)
10593 tem = !tem;
10594 type = language_bool_type (exp->language_defn, exp->gdbarch);
10595 return value_from_longest (type, (LONGEST) tem);
10596
10597 case UNOP_NEG:
10598 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10599 if (noside == EVAL_SKIP)
10600 goto nosideret;
10601 else if (ada_is_fixed_point_type (value_type (arg1)))
10602 return value_cast (value_type (arg1), value_neg (arg1));
10603 else
10604 {
10605 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10606 return value_neg (arg1);
10607 }
10608
10609 case BINOP_LOGICAL_AND:
10610 case BINOP_LOGICAL_OR:
10611 case UNOP_LOGICAL_NOT:
10612 {
10613 struct value *val;
10614
10615 *pos -= 1;
10616 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10617 type = language_bool_type (exp->language_defn, exp->gdbarch);
10618 return value_cast (type, val);
10619 }
10620
10621 case BINOP_BITWISE_AND:
10622 case BINOP_BITWISE_IOR:
10623 case BINOP_BITWISE_XOR:
10624 {
10625 struct value *val;
10626
10627 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10628 *pos = pc;
10629 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10630
10631 return value_cast (value_type (arg1), val);
10632 }
10633
10634 case OP_VAR_VALUE:
10635 *pos -= 1;
10636
10637 if (noside == EVAL_SKIP)
10638 {
10639 *pos += 4;
10640 goto nosideret;
10641 }
10642
10643 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
10644 /* Only encountered when an unresolved symbol occurs in a
10645 context other than a function call, in which case, it is
10646 invalid. */
10647 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10648 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
10649
10650 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10651 {
10652 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
10653 /* Check to see if this is a tagged type. We also need to handle
10654 the case where the type is a reference to a tagged type, but
10655 we have to be careful to exclude pointers to tagged types.
10656 The latter should be shown as usual (as a pointer), whereas
10657 a reference should mostly be transparent to the user. */
10658 if (ada_is_tagged_type (type, 0)
10659 || (TYPE_CODE (type) == TYPE_CODE_REF
10660 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10661 {
10662 /* Tagged types are a little special in the fact that the real
10663 type is dynamic and can only be determined by inspecting the
10664 object's tag. This means that we need to get the object's
10665 value first (EVAL_NORMAL) and then extract the actual object
10666 type from its tag.
10667
10668 Note that we cannot skip the final step where we extract
10669 the object type from its tag, because the EVAL_NORMAL phase
10670 results in dynamic components being resolved into fixed ones.
10671 This can cause problems when trying to print the type
10672 description of tagged types whose parent has a dynamic size:
10673 We use the type name of the "_parent" component in order
10674 to print the name of the ancestor type in the type description.
10675 If that component had a dynamic size, the resolution into
10676 a fixed type would result in the loss of that type name,
10677 thus preventing us from printing the name of the ancestor
10678 type in the type description. */
10679 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10680
10681 if (TYPE_CODE (type) != TYPE_CODE_REF)
10682 {
10683 struct type *actual_type;
10684
10685 actual_type = type_from_tag (ada_value_tag (arg1));
10686 if (actual_type == NULL)
10687 /* If, for some reason, we were unable to determine
10688 the actual type from the tag, then use the static
10689 approximation that we just computed as a fallback.
10690 This can happen if the debugging information is
10691 incomplete, for instance. */
10692 actual_type = type;
10693 return value_zero (actual_type, not_lval);
10694 }
10695 else
10696 {
10697 /* In the case of a ref, ada_coerce_ref takes care
10698 of determining the actual type. But the evaluation
10699 should return a ref as it should be valid to ask
10700 for its address; so rebuild a ref after coerce. */
10701 arg1 = ada_coerce_ref (arg1);
10702 return value_ref (arg1, TYPE_CODE_REF);
10703 }
10704 }
10705
10706 /* Records and unions for which GNAT encodings have been
10707 generated need to be statically fixed as well.
10708 Otherwise, non-static fixing produces a type where
10709 all dynamic properties are removed, which prevents "ptype"
10710 from being able to completely describe the type.
10711 For instance, a case statement in a variant record would be
10712 replaced by the relevant components based on the actual
10713 value of the discriminants. */
10714 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10715 && dynamic_template_type (type) != NULL)
10716 || (TYPE_CODE (type) == TYPE_CODE_UNION
10717 && ada_find_parallel_type (type, "___XVU") != NULL))
10718 {
10719 *pos += 4;
10720 return value_zero (to_static_fixed_type (type), not_lval);
10721 }
10722 }
10723
10724 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10725 return ada_to_fixed_value (arg1);
10726
10727 case OP_FUNCALL:
10728 (*pos) += 2;
10729
10730 /* Allocate arg vector, including space for the function to be
10731 called in argvec[0] and a terminating NULL. */
10732 nargs = longest_to_int (exp->elts[pc + 1].longconst);
10733 argvec = XALLOCAVEC (struct value *, nargs + 2);
10734
10735 if (exp->elts[*pos].opcode == OP_VAR_VALUE
10736 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
10737 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10738 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10739 else
10740 {
10741 for (tem = 0; tem <= nargs; tem += 1)
10742 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10743 argvec[tem] = 0;
10744
10745 if (noside == EVAL_SKIP)
10746 goto nosideret;
10747 }
10748
10749 if (ada_is_constrained_packed_array_type
10750 (desc_base_type (value_type (argvec[0]))))
10751 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
10752 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10753 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10754 /* This is a packed array that has already been fixed, and
10755 therefore already coerced to a simple array. Nothing further
10756 to do. */
10757 ;
10758 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10759 {
10760 /* Make sure we dereference references so that all the code below
10761 feels like it's really handling the referenced value. Wrapping
10762 types (for alignment) may be there, so make sure we strip them as
10763 well. */
10764 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10765 }
10766 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10767 && VALUE_LVAL (argvec[0]) == lval_memory)
10768 argvec[0] = value_addr (argvec[0]);
10769
10770 type = ada_check_typedef (value_type (argvec[0]));
10771
10772 /* Ada allows us to implicitly dereference arrays when subscripting
10773 them. So, if this is an array typedef (encoding use for array
10774 access types encoded as fat pointers), strip it now. */
10775 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10776 type = ada_typedef_target_type (type);
10777
10778 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10779 {
10780 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
10781 {
10782 case TYPE_CODE_FUNC:
10783 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10784 break;
10785 case TYPE_CODE_ARRAY:
10786 break;
10787 case TYPE_CODE_STRUCT:
10788 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10789 argvec[0] = ada_value_ind (argvec[0]);
10790 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10791 break;
10792 default:
10793 error (_("cannot subscript or call something of type `%s'"),
10794 ada_type_name (value_type (argvec[0])));
10795 break;
10796 }
10797 }
10798
10799 switch (TYPE_CODE (type))
10800 {
10801 case TYPE_CODE_FUNC:
10802 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10803 {
10804 if (TYPE_TARGET_TYPE (type) == NULL)
10805 error_call_unknown_return_type (NULL);
10806 return allocate_value (TYPE_TARGET_TYPE (type));
10807 }
10808 return call_function_by_hand (argvec[0], NULL,
10809 gdb::make_array_view (argvec + 1,
10810 nargs));
10811 case TYPE_CODE_INTERNAL_FUNCTION:
10812 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10813 /* We don't know anything about what the internal
10814 function might return, but we have to return
10815 something. */
10816 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10817 not_lval);
10818 else
10819 return call_internal_function (exp->gdbarch, exp->language_defn,
10820 argvec[0], nargs, argvec + 1);
10821
10822 case TYPE_CODE_STRUCT:
10823 {
10824 int arity;
10825
10826 arity = ada_array_arity (type);
10827 type = ada_array_element_type (type, nargs);
10828 if (type == NULL)
10829 error (_("cannot subscript or call a record"));
10830 if (arity != nargs)
10831 error (_("wrong number of subscripts; expecting %d"), arity);
10832 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10833 return value_zero (ada_aligned_type (type), lval_memory);
10834 return
10835 unwrap_value (ada_value_subscript
10836 (argvec[0], nargs, argvec + 1));
10837 }
10838 case TYPE_CODE_ARRAY:
10839 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10840 {
10841 type = ada_array_element_type (type, nargs);
10842 if (type == NULL)
10843 error (_("element type of array unknown"));
10844 else
10845 return value_zero (ada_aligned_type (type), lval_memory);
10846 }
10847 return
10848 unwrap_value (ada_value_subscript
10849 (ada_coerce_to_simple_array (argvec[0]),
10850 nargs, argvec + 1));
10851 case TYPE_CODE_PTR: /* Pointer to array */
10852 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10853 {
10854 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10855 type = ada_array_element_type (type, nargs);
10856 if (type == NULL)
10857 error (_("element type of array unknown"));
10858 else
10859 return value_zero (ada_aligned_type (type), lval_memory);
10860 }
10861 return
10862 unwrap_value (ada_value_ptr_subscript (argvec[0],
10863 nargs, argvec + 1));
10864
10865 default:
10866 error (_("Attempt to index or call something other than an "
10867 "array or function"));
10868 }
10869
10870 case TERNOP_SLICE:
10871 {
10872 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10873 struct value *low_bound_val =
10874 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10875 struct value *high_bound_val =
10876 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10877 LONGEST low_bound;
10878 LONGEST high_bound;
10879
10880 low_bound_val = coerce_ref (low_bound_val);
10881 high_bound_val = coerce_ref (high_bound_val);
10882 low_bound = value_as_long (low_bound_val);
10883 high_bound = value_as_long (high_bound_val);
10884
10885 if (noside == EVAL_SKIP)
10886 goto nosideret;
10887
10888 /* If this is a reference to an aligner type, then remove all
10889 the aligners. */
10890 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10891 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10892 TYPE_TARGET_TYPE (value_type (array)) =
10893 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
10894
10895 if (ada_is_constrained_packed_array_type (value_type (array)))
10896 error (_("cannot slice a packed array"));
10897
10898 /* If this is a reference to an array or an array lvalue,
10899 convert to a pointer. */
10900 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10901 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
10902 && VALUE_LVAL (array) == lval_memory))
10903 array = value_addr (array);
10904
10905 if (noside == EVAL_AVOID_SIDE_EFFECTS
10906 && ada_is_array_descriptor_type (ada_check_typedef
10907 (value_type (array))))
10908 return empty_array (ada_type_of_array (array, 0), low_bound,
10909 high_bound);
10910
10911 array = ada_coerce_to_simple_array_ptr (array);
10912
10913 /* If we have more than one level of pointer indirection,
10914 dereference the value until we get only one level. */
10915 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10916 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
10917 == TYPE_CODE_PTR))
10918 array = value_ind (array);
10919
10920 /* Make sure we really do have an array type before going further,
10921 to avoid a SEGV when trying to get the index type or the target
10922 type later down the road if the debug info generated by
10923 the compiler is incorrect or incomplete. */
10924 if (!ada_is_simple_array_type (value_type (array)))
10925 error (_("cannot take slice of non-array"));
10926
10927 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10928 == TYPE_CODE_PTR)
10929 {
10930 struct type *type0 = ada_check_typedef (value_type (array));
10931
10932 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10933 return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
10934 else
10935 {
10936 struct type *arr_type0 =
10937 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
10938
10939 return ada_value_slice_from_ptr (array, arr_type0,
10940 longest_to_int (low_bound),
10941 longest_to_int (high_bound));
10942 }
10943 }
10944 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10945 return array;
10946 else if (high_bound < low_bound)
10947 return empty_array (value_type (array), low_bound, high_bound);
10948 else
10949 return ada_value_slice (array, longest_to_int (low_bound),
10950 longest_to_int (high_bound));
10951 }
10952
10953 case UNOP_IN_RANGE:
10954 (*pos) += 2;
10955 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10956 type = check_typedef (exp->elts[pc + 1].type);
10957
10958 if (noside == EVAL_SKIP)
10959 goto nosideret;
10960
10961 switch (TYPE_CODE (type))
10962 {
10963 default:
10964 lim_warning (_("Membership test incompletely implemented; "
10965 "always returns true"));
10966 type = language_bool_type (exp->language_defn, exp->gdbarch);
10967 return value_from_longest (type, (LONGEST) 1);
10968
10969 case TYPE_CODE_RANGE:
10970 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10971 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
10972 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10973 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10974 type = language_bool_type (exp->language_defn, exp->gdbarch);
10975 return
10976 value_from_longest (type,
10977 (value_less (arg1, arg3)
10978 || value_equal (arg1, arg3))
10979 && (value_less (arg2, arg1)
10980 || value_equal (arg2, arg1)));
10981 }
10982
10983 case BINOP_IN_BOUNDS:
10984 (*pos) += 2;
10985 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10986 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10987
10988 if (noside == EVAL_SKIP)
10989 goto nosideret;
10990
10991 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10992 {
10993 type = language_bool_type (exp->language_defn, exp->gdbarch);
10994 return value_zero (type, not_lval);
10995 }
10996
10997 tem = longest_to_int (exp->elts[pc + 1].longconst);
10998
10999 type = ada_index_type (value_type (arg2), tem, "range");
11000 if (!type)
11001 type = value_type (arg1);
11002
11003 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
11004 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
11005
11006 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11007 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
11008 type = language_bool_type (exp->language_defn, exp->gdbarch);
11009 return
11010 value_from_longest (type,
11011 (value_less (arg1, arg3)
11012 || value_equal (arg1, arg3))
11013 && (value_less (arg2, arg1)
11014 || value_equal (arg2, arg1)));
11015
11016 case TERNOP_IN_RANGE:
11017 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11018 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11019 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11020
11021 if (noside == EVAL_SKIP)
11022 goto nosideret;
11023
11024 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11025 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
11026 type = language_bool_type (exp->language_defn, exp->gdbarch);
11027 return
11028 value_from_longest (type,
11029 (value_less (arg1, arg3)
11030 || value_equal (arg1, arg3))
11031 && (value_less (arg2, arg1)
11032 || value_equal (arg2, arg1)));
11033
11034 case OP_ATR_FIRST:
11035 case OP_ATR_LAST:
11036 case OP_ATR_LENGTH:
11037 {
11038 struct type *type_arg;
11039
11040 if (exp->elts[*pos].opcode == OP_TYPE)
11041 {
11042 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11043 arg1 = NULL;
11044 type_arg = check_typedef (exp->elts[pc + 2].type);
11045 }
11046 else
11047 {
11048 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11049 type_arg = NULL;
11050 }
11051
11052 if (exp->elts[*pos].opcode != OP_LONG)
11053 error (_("Invalid operand to '%s"), ada_attribute_name (op));
11054 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11055 *pos += 4;
11056
11057 if (noside == EVAL_SKIP)
11058 goto nosideret;
11059
11060 if (type_arg == NULL)
11061 {
11062 arg1 = ada_coerce_ref (arg1);
11063
11064 if (ada_is_constrained_packed_array_type (value_type (arg1)))
11065 arg1 = ada_coerce_to_simple_array (arg1);
11066
11067 if (op == OP_ATR_LENGTH)
11068 type = builtin_type (exp->gdbarch)->builtin_int;
11069 else
11070 {
11071 type = ada_index_type (value_type (arg1), tem,
11072 ada_attribute_name (op));
11073 if (type == NULL)
11074 type = builtin_type (exp->gdbarch)->builtin_int;
11075 }
11076
11077 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11078 return allocate_value (type);
11079
11080 switch (op)
11081 {
11082 default: /* Should never happen. */
11083 error (_("unexpected attribute encountered"));
11084 case OP_ATR_FIRST:
11085 return value_from_longest
11086 (type, ada_array_bound (arg1, tem, 0));
11087 case OP_ATR_LAST:
11088 return value_from_longest
11089 (type, ada_array_bound (arg1, tem, 1));
11090 case OP_ATR_LENGTH:
11091 return value_from_longest
11092 (type, ada_array_length (arg1, tem));
11093 }
11094 }
11095 else if (discrete_type_p (type_arg))
11096 {
11097 struct type *range_type;
11098 const char *name = ada_type_name (type_arg);
11099
11100 range_type = NULL;
11101 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
11102 range_type = to_fixed_range_type (type_arg, NULL);
11103 if (range_type == NULL)
11104 range_type = type_arg;
11105 switch (op)
11106 {
11107 default:
11108 error (_("unexpected attribute encountered"));
11109 case OP_ATR_FIRST:
11110 return value_from_longest
11111 (range_type, ada_discrete_type_low_bound (range_type));
11112 case OP_ATR_LAST:
11113 return value_from_longest
11114 (range_type, ada_discrete_type_high_bound (range_type));
11115 case OP_ATR_LENGTH:
11116 error (_("the 'length attribute applies only to array types"));
11117 }
11118 }
11119 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
11120 error (_("unimplemented type attribute"));
11121 else
11122 {
11123 LONGEST low, high;
11124
11125 if (ada_is_constrained_packed_array_type (type_arg))
11126 type_arg = decode_constrained_packed_array_type (type_arg);
11127
11128 if (op == OP_ATR_LENGTH)
11129 type = builtin_type (exp->gdbarch)->builtin_int;
11130 else
11131 {
11132 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11133 if (type == NULL)
11134 type = builtin_type (exp->gdbarch)->builtin_int;
11135 }
11136
11137 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11138 return allocate_value (type);
11139
11140 switch (op)
11141 {
11142 default:
11143 error (_("unexpected attribute encountered"));
11144 case OP_ATR_FIRST:
11145 low = ada_array_bound_from_type (type_arg, tem, 0);
11146 return value_from_longest (type, low);
11147 case OP_ATR_LAST:
11148 high = ada_array_bound_from_type (type_arg, tem, 1);
11149 return value_from_longest (type, high);
11150 case OP_ATR_LENGTH:
11151 low = ada_array_bound_from_type (type_arg, tem, 0);
11152 high = ada_array_bound_from_type (type_arg, tem, 1);
11153 return value_from_longest (type, high - low + 1);
11154 }
11155 }
11156 }
11157
11158 case OP_ATR_TAG:
11159 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11160 if (noside == EVAL_SKIP)
11161 goto nosideret;
11162
11163 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11164 return value_zero (ada_tag_type (arg1), not_lval);
11165
11166 return ada_value_tag (arg1);
11167
11168 case OP_ATR_MIN:
11169 case OP_ATR_MAX:
11170 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11171 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11172 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11173 if (noside == EVAL_SKIP)
11174 goto nosideret;
11175 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11176 return value_zero (value_type (arg1), not_lval);
11177 else
11178 {
11179 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11180 return value_binop (arg1, arg2,
11181 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11182 }
11183
11184 case OP_ATR_MODULUS:
11185 {
11186 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
11187
11188 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11189 if (noside == EVAL_SKIP)
11190 goto nosideret;
11191
11192 if (!ada_is_modular_type (type_arg))
11193 error (_("'modulus must be applied to modular type"));
11194
11195 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11196 ada_modulus (type_arg));
11197 }
11198
11199
11200 case OP_ATR_POS:
11201 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11202 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11203 if (noside == EVAL_SKIP)
11204 goto nosideret;
11205 type = builtin_type (exp->gdbarch)->builtin_int;
11206 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11207 return value_zero (type, not_lval);
11208 else
11209 return value_pos_atr (type, arg1);
11210
11211 case OP_ATR_SIZE:
11212 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11213 type = value_type (arg1);
11214
11215 /* If the argument is a reference, then dereference its type, since
11216 the user is really asking for the size of the actual object,
11217 not the size of the pointer. */
11218 if (TYPE_CODE (type) == TYPE_CODE_REF)
11219 type = TYPE_TARGET_TYPE (type);
11220
11221 if (noside == EVAL_SKIP)
11222 goto nosideret;
11223 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11224 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
11225 else
11226 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
11227 TARGET_CHAR_BIT * TYPE_LENGTH (type));
11228
11229 case OP_ATR_VAL:
11230 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11231 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11232 type = exp->elts[pc + 2].type;
11233 if (noside == EVAL_SKIP)
11234 goto nosideret;
11235 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11236 return value_zero (type, not_lval);
11237 else
11238 return value_val_atr (type, arg1);
11239
11240 case BINOP_EXP:
11241 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11242 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11243 if (noside == EVAL_SKIP)
11244 goto nosideret;
11245 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11246 return value_zero (value_type (arg1), not_lval);
11247 else
11248 {
11249 /* For integer exponentiation operations,
11250 only promote the first argument. */
11251 if (is_integral_type (value_type (arg2)))
11252 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11253 else
11254 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11255
11256 return value_binop (arg1, arg2, op);
11257 }
11258
11259 case UNOP_PLUS:
11260 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11261 if (noside == EVAL_SKIP)
11262 goto nosideret;
11263 else
11264 return arg1;
11265
11266 case UNOP_ABS:
11267 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11268 if (noside == EVAL_SKIP)
11269 goto nosideret;
11270 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11271 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
11272 return value_neg (arg1);
11273 else
11274 return arg1;
11275
11276 case UNOP_IND:
11277 preeval_pos = *pos;
11278 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11279 if (noside == EVAL_SKIP)
11280 goto nosideret;
11281 type = ada_check_typedef (value_type (arg1));
11282 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11283 {
11284 if (ada_is_array_descriptor_type (type))
11285 /* GDB allows dereferencing GNAT array descriptors. */
11286 {
11287 struct type *arrType = ada_type_of_array (arg1, 0);
11288
11289 if (arrType == NULL)
11290 error (_("Attempt to dereference null array pointer."));
11291 return value_at_lazy (arrType, 0);
11292 }
11293 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11294 || TYPE_CODE (type) == TYPE_CODE_REF
11295 /* In C you can dereference an array to get the 1st elt. */
11296 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
11297 {
11298 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11299 only be determined by inspecting the object's tag.
11300 This means that we need to evaluate completely the
11301 expression in order to get its type. */
11302
11303 if ((TYPE_CODE (type) == TYPE_CODE_REF
11304 || TYPE_CODE (type) == TYPE_CODE_PTR)
11305 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11306 {
11307 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11308 EVAL_NORMAL);
11309 type = value_type (ada_value_ind (arg1));
11310 }
11311 else
11312 {
11313 type = to_static_fixed_type
11314 (ada_aligned_type
11315 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11316 }
11317 ada_ensure_varsize_limit (type);
11318 return value_zero (type, lval_memory);
11319 }
11320 else if (TYPE_CODE (type) == TYPE_CODE_INT)
11321 {
11322 /* GDB allows dereferencing an int. */
11323 if (expect_type == NULL)
11324 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11325 lval_memory);
11326 else
11327 {
11328 expect_type =
11329 to_static_fixed_type (ada_aligned_type (expect_type));
11330 return value_zero (expect_type, lval_memory);
11331 }
11332 }
11333 else
11334 error (_("Attempt to take contents of a non-pointer value."));
11335 }
11336 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
11337 type = ada_check_typedef (value_type (arg1));
11338
11339 if (TYPE_CODE (type) == TYPE_CODE_INT)
11340 /* GDB allows dereferencing an int. If we were given
11341 the expect_type, then use that as the target type.
11342 Otherwise, assume that the target type is an int. */
11343 {
11344 if (expect_type != NULL)
11345 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11346 arg1));
11347 else
11348 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11349 (CORE_ADDR) value_as_address (arg1));
11350 }
11351
11352 if (ada_is_array_descriptor_type (type))
11353 /* GDB allows dereferencing GNAT array descriptors. */
11354 return ada_coerce_to_simple_array (arg1);
11355 else
11356 return ada_value_ind (arg1);
11357
11358 case STRUCTOP_STRUCT:
11359 tem = longest_to_int (exp->elts[pc + 1].longconst);
11360 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
11361 preeval_pos = *pos;
11362 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11363 if (noside == EVAL_SKIP)
11364 goto nosideret;
11365 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11366 {
11367 struct type *type1 = value_type (arg1);
11368
11369 if (ada_is_tagged_type (type1, 1))
11370 {
11371 type = ada_lookup_struct_elt_type (type1,
11372 &exp->elts[pc + 2].string,
11373 1, 1);
11374
11375 /* If the field is not found, check if it exists in the
11376 extension of this object's type. This means that we
11377 need to evaluate completely the expression. */
11378
11379 if (type == NULL)
11380 {
11381 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11382 EVAL_NORMAL);
11383 arg1 = ada_value_struct_elt (arg1,
11384 &exp->elts[pc + 2].string,
11385 0);
11386 arg1 = unwrap_value (arg1);
11387 type = value_type (ada_to_fixed_value (arg1));
11388 }
11389 }
11390 else
11391 type =
11392 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
11393 0);
11394
11395 return value_zero (ada_aligned_type (type), lval_memory);
11396 }
11397 else
11398 {
11399 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11400 arg1 = unwrap_value (arg1);
11401 return ada_to_fixed_value (arg1);
11402 }
11403
11404 case OP_TYPE:
11405 /* The value is not supposed to be used. This is here to make it
11406 easier to accommodate expressions that contain types. */
11407 (*pos) += 2;
11408 if (noside == EVAL_SKIP)
11409 goto nosideret;
11410 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11411 return allocate_value (exp->elts[pc + 1].type);
11412 else
11413 error (_("Attempt to use a type name as an expression"));
11414
11415 case OP_AGGREGATE:
11416 case OP_CHOICES:
11417 case OP_OTHERS:
11418 case OP_DISCRETE_RANGE:
11419 case OP_POSITIONAL:
11420 case OP_NAME:
11421 if (noside == EVAL_NORMAL)
11422 switch (op)
11423 {
11424 case OP_NAME:
11425 error (_("Undefined name, ambiguous name, or renaming used in "
11426 "component association: %s."), &exp->elts[pc+2].string);
11427 case OP_AGGREGATE:
11428 error (_("Aggregates only allowed on the right of an assignment"));
11429 default:
11430 internal_error (__FILE__, __LINE__,
11431 _("aggregate apparently mangled"));
11432 }
11433
11434 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11435 *pos += oplen - 1;
11436 for (tem = 0; tem < nargs; tem += 1)
11437 ada_evaluate_subexp (NULL, exp, pos, noside);
11438 goto nosideret;
11439 }
11440
11441 nosideret:
11442 return eval_skip_value (exp);
11443 }
11444 \f
11445
11446 /* Fixed point */
11447
11448 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11449 type name that encodes the 'small and 'delta information.
11450 Otherwise, return NULL. */
11451
11452 static const char *
11453 fixed_type_info (struct type *type)
11454 {
11455 const char *name = ada_type_name (type);
11456 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11457
11458 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11459 {
11460 const char *tail = strstr (name, "___XF_");
11461
11462 if (tail == NULL)
11463 return NULL;
11464 else
11465 return tail + 5;
11466 }
11467 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11468 return fixed_type_info (TYPE_TARGET_TYPE (type));
11469 else
11470 return NULL;
11471 }
11472
11473 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11474
11475 int
11476 ada_is_fixed_point_type (struct type *type)
11477 {
11478 return fixed_type_info (type) != NULL;
11479 }
11480
11481 /* Return non-zero iff TYPE represents a System.Address type. */
11482
11483 int
11484 ada_is_system_address_type (struct type *type)
11485 {
11486 return (TYPE_NAME (type)
11487 && strcmp (TYPE_NAME (type), "system__address") == 0);
11488 }
11489
11490 /* Assuming that TYPE is the representation of an Ada fixed-point
11491 type, return the target floating-point type to be used to represent
11492 of this type during internal computation. */
11493
11494 static struct type *
11495 ada_scaling_type (struct type *type)
11496 {
11497 return builtin_type (get_type_arch (type))->builtin_long_double;
11498 }
11499
11500 /* Assuming that TYPE is the representation of an Ada fixed-point
11501 type, return its delta, or NULL if the type is malformed and the
11502 delta cannot be determined. */
11503
11504 struct value *
11505 ada_delta (struct type *type)
11506 {
11507 const char *encoding = fixed_type_info (type);
11508 struct type *scale_type = ada_scaling_type (type);
11509
11510 long long num, den;
11511
11512 if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11513 return nullptr;
11514 else
11515 return value_binop (value_from_longest (scale_type, num),
11516 value_from_longest (scale_type, den), BINOP_DIV);
11517 }
11518
11519 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
11520 factor ('SMALL value) associated with the type. */
11521
11522 struct value *
11523 ada_scaling_factor (struct type *type)
11524 {
11525 const char *encoding = fixed_type_info (type);
11526 struct type *scale_type = ada_scaling_type (type);
11527
11528 long long num0, den0, num1, den1;
11529 int n;
11530
11531 n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
11532 &num0, &den0, &num1, &den1);
11533
11534 if (n < 2)
11535 return value_from_longest (scale_type, 1);
11536 else if (n == 4)
11537 return value_binop (value_from_longest (scale_type, num1),
11538 value_from_longest (scale_type, den1), BINOP_DIV);
11539 else
11540 return value_binop (value_from_longest (scale_type, num0),
11541 value_from_longest (scale_type, den0), BINOP_DIV);
11542 }
11543
11544 \f
11545
11546 /* Range types */
11547
11548 /* Scan STR beginning at position K for a discriminant name, and
11549 return the value of that discriminant field of DVAL in *PX. If
11550 PNEW_K is not null, put the position of the character beyond the
11551 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11552 not alter *PX and *PNEW_K if unsuccessful. */
11553
11554 static int
11555 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11556 int *pnew_k)
11557 {
11558 static char *bound_buffer = NULL;
11559 static size_t bound_buffer_len = 0;
11560 const char *pstart, *pend, *bound;
11561 struct value *bound_val;
11562
11563 if (dval == NULL || str == NULL || str[k] == '\0')
11564 return 0;
11565
11566 pstart = str + k;
11567 pend = strstr (pstart, "__");
11568 if (pend == NULL)
11569 {
11570 bound = pstart;
11571 k += strlen (bound);
11572 }
11573 else
11574 {
11575 int len = pend - pstart;
11576
11577 /* Strip __ and beyond. */
11578 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11579 strncpy (bound_buffer, pstart, len);
11580 bound_buffer[len] = '\0';
11581
11582 bound = bound_buffer;
11583 k = pend - str;
11584 }
11585
11586 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11587 if (bound_val == NULL)
11588 return 0;
11589
11590 *px = value_as_long (bound_val);
11591 if (pnew_k != NULL)
11592 *pnew_k = k;
11593 return 1;
11594 }
11595
11596 /* Value of variable named NAME in the current environment. If
11597 no such variable found, then if ERR_MSG is null, returns 0, and
11598 otherwise causes an error with message ERR_MSG. */
11599
11600 static struct value *
11601 get_var_value (const char *name, const char *err_msg)
11602 {
11603 lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
11604
11605 std::vector<struct block_symbol> syms;
11606 int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11607 get_selected_block (0),
11608 VAR_DOMAIN, &syms, 1);
11609
11610 if (nsyms != 1)
11611 {
11612 if (err_msg == NULL)
11613 return 0;
11614 else
11615 error (("%s"), err_msg);
11616 }
11617
11618 return value_of_variable (syms[0].symbol, syms[0].block);
11619 }
11620
11621 /* Value of integer variable named NAME in the current environment.
11622 If no such variable is found, returns false. Otherwise, sets VALUE
11623 to the variable's value and returns true. */
11624
11625 bool
11626 get_int_var_value (const char *name, LONGEST &value)
11627 {
11628 struct value *var_val = get_var_value (name, 0);
11629
11630 if (var_val == 0)
11631 return false;
11632
11633 value = value_as_long (var_val);
11634 return true;
11635 }
11636
11637
11638 /* Return a range type whose base type is that of the range type named
11639 NAME in the current environment, and whose bounds are calculated
11640 from NAME according to the GNAT range encoding conventions.
11641 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11642 corresponding range type from debug information; fall back to using it
11643 if symbol lookup fails. If a new type must be created, allocate it
11644 like ORIG_TYPE was. The bounds information, in general, is encoded
11645 in NAME, the base type given in the named range type. */
11646
11647 static struct type *
11648 to_fixed_range_type (struct type *raw_type, struct value *dval)
11649 {
11650 const char *name;
11651 struct type *base_type;
11652 const char *subtype_info;
11653
11654 gdb_assert (raw_type != NULL);
11655 gdb_assert (TYPE_NAME (raw_type) != NULL);
11656
11657 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
11658 base_type = TYPE_TARGET_TYPE (raw_type);
11659 else
11660 base_type = raw_type;
11661
11662 name = TYPE_NAME (raw_type);
11663 subtype_info = strstr (name, "___XD");
11664 if (subtype_info == NULL)
11665 {
11666 LONGEST L = ada_discrete_type_low_bound (raw_type);
11667 LONGEST U = ada_discrete_type_high_bound (raw_type);
11668
11669 if (L < INT_MIN || U > INT_MAX)
11670 return raw_type;
11671 else
11672 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11673 L, U);
11674 }
11675 else
11676 {
11677 static char *name_buf = NULL;
11678 static size_t name_len = 0;
11679 int prefix_len = subtype_info - name;
11680 LONGEST L, U;
11681 struct type *type;
11682 const char *bounds_str;
11683 int n;
11684
11685 GROW_VECT (name_buf, name_len, prefix_len + 5);
11686 strncpy (name_buf, name, prefix_len);
11687 name_buf[prefix_len] = '\0';
11688
11689 subtype_info += 5;
11690 bounds_str = strchr (subtype_info, '_');
11691 n = 1;
11692
11693 if (*subtype_info == 'L')
11694 {
11695 if (!ada_scan_number (bounds_str, n, &L, &n)
11696 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11697 return raw_type;
11698 if (bounds_str[n] == '_')
11699 n += 2;
11700 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
11701 n += 1;
11702 subtype_info += 1;
11703 }
11704 else
11705 {
11706 strcpy (name_buf + prefix_len, "___L");
11707 if (!get_int_var_value (name_buf, L))
11708 {
11709 lim_warning (_("Unknown lower bound, using 1."));
11710 L = 1;
11711 }
11712 }
11713
11714 if (*subtype_info == 'U')
11715 {
11716 if (!ada_scan_number (bounds_str, n, &U, &n)
11717 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11718 return raw_type;
11719 }
11720 else
11721 {
11722 strcpy (name_buf + prefix_len, "___U");
11723 if (!get_int_var_value (name_buf, U))
11724 {
11725 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11726 U = L;
11727 }
11728 }
11729
11730 type = create_static_range_type (alloc_type_copy (raw_type),
11731 base_type, L, U);
11732 /* create_static_range_type alters the resulting type's length
11733 to match the size of the base_type, which is not what we want.
11734 Set it back to the original range type's length. */
11735 TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
11736 TYPE_NAME (type) = name;
11737 return type;
11738 }
11739 }
11740
11741 /* True iff NAME is the name of a range type. */
11742
11743 int
11744 ada_is_range_type_name (const char *name)
11745 {
11746 return (name != NULL && strstr (name, "___XD"));
11747 }
11748 \f
11749
11750 /* Modular types */
11751
11752 /* True iff TYPE is an Ada modular type. */
11753
11754 int
11755 ada_is_modular_type (struct type *type)
11756 {
11757 struct type *subranged_type = get_base_type (type);
11758
11759 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
11760 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
11761 && TYPE_UNSIGNED (subranged_type));
11762 }
11763
11764 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11765
11766 ULONGEST
11767 ada_modulus (struct type *type)
11768 {
11769 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
11770 }
11771 \f
11772
11773 /* Ada exception catchpoint support:
11774 ---------------------------------
11775
11776 We support 3 kinds of exception catchpoints:
11777 . catchpoints on Ada exceptions
11778 . catchpoints on unhandled Ada exceptions
11779 . catchpoints on failed assertions
11780
11781 Exceptions raised during failed assertions, or unhandled exceptions
11782 could perfectly be caught with the general catchpoint on Ada exceptions.
11783 However, we can easily differentiate these two special cases, and having
11784 the option to distinguish these two cases from the rest can be useful
11785 to zero-in on certain situations.
11786
11787 Exception catchpoints are a specialized form of breakpoint,
11788 since they rely on inserting breakpoints inside known routines
11789 of the GNAT runtime. The implementation therefore uses a standard
11790 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11791 of breakpoint_ops.
11792
11793 Support in the runtime for exception catchpoints have been changed
11794 a few times already, and these changes affect the implementation
11795 of these catchpoints. In order to be able to support several
11796 variants of the runtime, we use a sniffer that will determine
11797 the runtime variant used by the program being debugged. */
11798
11799 /* Ada's standard exceptions.
11800
11801 The Ada 83 standard also defined Numeric_Error. But there so many
11802 situations where it was unclear from the Ada 83 Reference Manual
11803 (RM) whether Constraint_Error or Numeric_Error should be raised,
11804 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11805 Interpretation saying that anytime the RM says that Numeric_Error
11806 should be raised, the implementation may raise Constraint_Error.
11807 Ada 95 went one step further and pretty much removed Numeric_Error
11808 from the list of standard exceptions (it made it a renaming of
11809 Constraint_Error, to help preserve compatibility when compiling
11810 an Ada83 compiler). As such, we do not include Numeric_Error from
11811 this list of standard exceptions. */
11812
11813 static const char *standard_exc[] = {
11814 "constraint_error",
11815 "program_error",
11816 "storage_error",
11817 "tasking_error"
11818 };
11819
11820 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11821
11822 /* A structure that describes how to support exception catchpoints
11823 for a given executable. */
11824
11825 struct exception_support_info
11826 {
11827 /* The name of the symbol to break on in order to insert
11828 a catchpoint on exceptions. */
11829 const char *catch_exception_sym;
11830
11831 /* The name of the symbol to break on in order to insert
11832 a catchpoint on unhandled exceptions. */
11833 const char *catch_exception_unhandled_sym;
11834
11835 /* The name of the symbol to break on in order to insert
11836 a catchpoint on failed assertions. */
11837 const char *catch_assert_sym;
11838
11839 /* The name of the symbol to break on in order to insert
11840 a catchpoint on exception handling. */
11841 const char *catch_handlers_sym;
11842
11843 /* Assuming that the inferior just triggered an unhandled exception
11844 catchpoint, this function is responsible for returning the address
11845 in inferior memory where the name of that exception is stored.
11846 Return zero if the address could not be computed. */
11847 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11848 };
11849
11850 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11851 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11852
11853 /* The following exception support info structure describes how to
11854 implement exception catchpoints with the latest version of the
11855 Ada runtime (as of 2007-03-06). */
11856
11857 static const struct exception_support_info default_exception_support_info =
11858 {
11859 "__gnat_debug_raise_exception", /* catch_exception_sym */
11860 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11861 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11862 "__gnat_begin_handler", /* catch_handlers_sym */
11863 ada_unhandled_exception_name_addr
11864 };
11865
11866 /* The following exception support info structure describes how to
11867 implement exception catchpoints with a slightly older version
11868 of the Ada runtime. */
11869
11870 static const struct exception_support_info exception_support_info_fallback =
11871 {
11872 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11873 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11874 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11875 "__gnat_begin_handler", /* catch_handlers_sym */
11876 ada_unhandled_exception_name_addr_from_raise
11877 };
11878
11879 /* Return nonzero if we can detect the exception support routines
11880 described in EINFO.
11881
11882 This function errors out if an abnormal situation is detected
11883 (for instance, if we find the exception support routines, but
11884 that support is found to be incomplete). */
11885
11886 static int
11887 ada_has_this_exception_support (const struct exception_support_info *einfo)
11888 {
11889 struct symbol *sym;
11890
11891 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11892 that should be compiled with debugging information. As a result, we
11893 expect to find that symbol in the symtabs. */
11894
11895 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11896 if (sym == NULL)
11897 {
11898 /* Perhaps we did not find our symbol because the Ada runtime was
11899 compiled without debugging info, or simply stripped of it.
11900 It happens on some GNU/Linux distributions for instance, where
11901 users have to install a separate debug package in order to get
11902 the runtime's debugging info. In that situation, let the user
11903 know why we cannot insert an Ada exception catchpoint.
11904
11905 Note: Just for the purpose of inserting our Ada exception
11906 catchpoint, we could rely purely on the associated minimal symbol.
11907 But we would be operating in degraded mode anyway, since we are
11908 still lacking the debugging info needed later on to extract
11909 the name of the exception being raised (this name is printed in
11910 the catchpoint message, and is also used when trying to catch
11911 a specific exception). We do not handle this case for now. */
11912 struct bound_minimal_symbol msym
11913 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11914
11915 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11916 error (_("Your Ada runtime appears to be missing some debugging "
11917 "information.\nCannot insert Ada exception catchpoint "
11918 "in this configuration."));
11919
11920 return 0;
11921 }
11922
11923 /* Make sure that the symbol we found corresponds to a function. */
11924
11925 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11926 error (_("Symbol \"%s\" is not a function (class = %d)"),
11927 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11928
11929 return 1;
11930 }
11931
11932 /* Inspect the Ada runtime and determine which exception info structure
11933 should be used to provide support for exception catchpoints.
11934
11935 This function will always set the per-inferior exception_info,
11936 or raise an error. */
11937
11938 static void
11939 ada_exception_support_info_sniffer (void)
11940 {
11941 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11942
11943 /* If the exception info is already known, then no need to recompute it. */
11944 if (data->exception_info != NULL)
11945 return;
11946
11947 /* Check the latest (default) exception support info. */
11948 if (ada_has_this_exception_support (&default_exception_support_info))
11949 {
11950 data->exception_info = &default_exception_support_info;
11951 return;
11952 }
11953
11954 /* Try our fallback exception suport info. */
11955 if (ada_has_this_exception_support (&exception_support_info_fallback))
11956 {
11957 data->exception_info = &exception_support_info_fallback;
11958 return;
11959 }
11960
11961 /* Sometimes, it is normal for us to not be able to find the routine
11962 we are looking for. This happens when the program is linked with
11963 the shared version of the GNAT runtime, and the program has not been
11964 started yet. Inform the user of these two possible causes if
11965 applicable. */
11966
11967 if (ada_update_initial_language (language_unknown) != language_ada)
11968 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11969
11970 /* If the symbol does not exist, then check that the program is
11971 already started, to make sure that shared libraries have been
11972 loaded. If it is not started, this may mean that the symbol is
11973 in a shared library. */
11974
11975 if (inferior_ptid.pid () == 0)
11976 error (_("Unable to insert catchpoint. Try to start the program first."));
11977
11978 /* At this point, we know that we are debugging an Ada program and
11979 that the inferior has been started, but we still are not able to
11980 find the run-time symbols. That can mean that we are in
11981 configurable run time mode, or that a-except as been optimized
11982 out by the linker... In any case, at this point it is not worth
11983 supporting this feature. */
11984
11985 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11986 }
11987
11988 /* True iff FRAME is very likely to be that of a function that is
11989 part of the runtime system. This is all very heuristic, but is
11990 intended to be used as advice as to what frames are uninteresting
11991 to most users. */
11992
11993 static int
11994 is_known_support_routine (struct frame_info *frame)
11995 {
11996 enum language func_lang;
11997 int i;
11998 const char *fullname;
11999
12000 /* If this code does not have any debugging information (no symtab),
12001 This cannot be any user code. */
12002
12003 symtab_and_line sal = find_frame_sal (frame);
12004 if (sal.symtab == NULL)
12005 return 1;
12006
12007 /* If there is a symtab, but the associated source file cannot be
12008 located, then assume this is not user code: Selecting a frame
12009 for which we cannot display the code would not be very helpful
12010 for the user. This should also take care of case such as VxWorks
12011 where the kernel has some debugging info provided for a few units. */
12012
12013 fullname = symtab_to_fullname (sal.symtab);
12014 if (access (fullname, R_OK) != 0)
12015 return 1;
12016
12017 /* Check the unit filename againt the Ada runtime file naming.
12018 We also check the name of the objfile against the name of some
12019 known system libraries that sometimes come with debugging info
12020 too. */
12021
12022 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12023 {
12024 re_comp (known_runtime_file_name_patterns[i]);
12025 if (re_exec (lbasename (sal.symtab->filename)))
12026 return 1;
12027 if (SYMTAB_OBJFILE (sal.symtab) != NULL
12028 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
12029 return 1;
12030 }
12031
12032 /* Check whether the function is a GNAT-generated entity. */
12033
12034 gdb::unique_xmalloc_ptr<char> func_name
12035 = find_frame_funname (frame, &func_lang, NULL);
12036 if (func_name == NULL)
12037 return 1;
12038
12039 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12040 {
12041 re_comp (known_auxiliary_function_name_patterns[i]);
12042 if (re_exec (func_name.get ()))
12043 return 1;
12044 }
12045
12046 return 0;
12047 }
12048
12049 /* Find the first frame that contains debugging information and that is not
12050 part of the Ada run-time, starting from FI and moving upward. */
12051
12052 void
12053 ada_find_printable_frame (struct frame_info *fi)
12054 {
12055 for (; fi != NULL; fi = get_prev_frame (fi))
12056 {
12057 if (!is_known_support_routine (fi))
12058 {
12059 select_frame (fi);
12060 break;
12061 }
12062 }
12063
12064 }
12065
12066 /* Assuming that the inferior just triggered an unhandled exception
12067 catchpoint, return the address in inferior memory where the name
12068 of the exception is stored.
12069
12070 Return zero if the address could not be computed. */
12071
12072 static CORE_ADDR
12073 ada_unhandled_exception_name_addr (void)
12074 {
12075 return parse_and_eval_address ("e.full_name");
12076 }
12077
12078 /* Same as ada_unhandled_exception_name_addr, except that this function
12079 should be used when the inferior uses an older version of the runtime,
12080 where the exception name needs to be extracted from a specific frame
12081 several frames up in the callstack. */
12082
12083 static CORE_ADDR
12084 ada_unhandled_exception_name_addr_from_raise (void)
12085 {
12086 int frame_level;
12087 struct frame_info *fi;
12088 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12089
12090 /* To determine the name of this exception, we need to select
12091 the frame corresponding to RAISE_SYM_NAME. This frame is
12092 at least 3 levels up, so we simply skip the first 3 frames
12093 without checking the name of their associated function. */
12094 fi = get_current_frame ();
12095 for (frame_level = 0; frame_level < 3; frame_level += 1)
12096 if (fi != NULL)
12097 fi = get_prev_frame (fi);
12098
12099 while (fi != NULL)
12100 {
12101 enum language func_lang;
12102
12103 gdb::unique_xmalloc_ptr<char> func_name
12104 = find_frame_funname (fi, &func_lang, NULL);
12105 if (func_name != NULL)
12106 {
12107 if (strcmp (func_name.get (),
12108 data->exception_info->catch_exception_sym) == 0)
12109 break; /* We found the frame we were looking for... */
12110 }
12111 fi = get_prev_frame (fi);
12112 }
12113
12114 if (fi == NULL)
12115 return 0;
12116
12117 select_frame (fi);
12118 return parse_and_eval_address ("id.full_name");
12119 }
12120
12121 /* Assuming the inferior just triggered an Ada exception catchpoint
12122 (of any type), return the address in inferior memory where the name
12123 of the exception is stored, if applicable.
12124
12125 Assumes the selected frame is the current frame.
12126
12127 Return zero if the address could not be computed, or if not relevant. */
12128
12129 static CORE_ADDR
12130 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
12131 struct breakpoint *b)
12132 {
12133 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12134
12135 switch (ex)
12136 {
12137 case ada_catch_exception:
12138 return (parse_and_eval_address ("e.full_name"));
12139 break;
12140
12141 case ada_catch_exception_unhandled:
12142 return data->exception_info->unhandled_exception_name_addr ();
12143 break;
12144
12145 case ada_catch_handlers:
12146 return 0; /* The runtimes does not provide access to the exception
12147 name. */
12148 break;
12149
12150 case ada_catch_assert:
12151 return 0; /* Exception name is not relevant in this case. */
12152 break;
12153
12154 default:
12155 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12156 break;
12157 }
12158
12159 return 0; /* Should never be reached. */
12160 }
12161
12162 /* Assuming the inferior is stopped at an exception catchpoint,
12163 return the message which was associated to the exception, if
12164 available. Return NULL if the message could not be retrieved.
12165
12166 Note: The exception message can be associated to an exception
12167 either through the use of the Raise_Exception function, or
12168 more simply (Ada 2005 and later), via:
12169
12170 raise Exception_Name with "exception message";
12171
12172 */
12173
12174 static gdb::unique_xmalloc_ptr<char>
12175 ada_exception_message_1 (void)
12176 {
12177 struct value *e_msg_val;
12178 int e_msg_len;
12179
12180 /* For runtimes that support this feature, the exception message
12181 is passed as an unbounded string argument called "message". */
12182 e_msg_val = parse_and_eval ("message");
12183 if (e_msg_val == NULL)
12184 return NULL; /* Exception message not supported. */
12185
12186 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12187 gdb_assert (e_msg_val != NULL);
12188 e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12189
12190 /* If the message string is empty, then treat it as if there was
12191 no exception message. */
12192 if (e_msg_len <= 0)
12193 return NULL;
12194
12195 gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12196 read_memory_string (value_address (e_msg_val), e_msg.get (), e_msg_len + 1);
12197 e_msg.get ()[e_msg_len] = '\0';
12198
12199 return e_msg;
12200 }
12201
12202 /* Same as ada_exception_message_1, except that all exceptions are
12203 contained here (returning NULL instead). */
12204
12205 static gdb::unique_xmalloc_ptr<char>
12206 ada_exception_message (void)
12207 {
12208 gdb::unique_xmalloc_ptr<char> e_msg;
12209
12210 try
12211 {
12212 e_msg = ada_exception_message_1 ();
12213 }
12214 catch (const gdb_exception_error &e)
12215 {
12216 e_msg.reset (nullptr);
12217 }
12218
12219 return e_msg;
12220 }
12221
12222 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12223 any error that ada_exception_name_addr_1 might cause to be thrown.
12224 When an error is intercepted, a warning with the error message is printed,
12225 and zero is returned. */
12226
12227 static CORE_ADDR
12228 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
12229 struct breakpoint *b)
12230 {
12231 CORE_ADDR result = 0;
12232
12233 try
12234 {
12235 result = ada_exception_name_addr_1 (ex, b);
12236 }
12237
12238 catch (const gdb_exception_error &e)
12239 {
12240 warning (_("failed to get exception name: %s"), e.what ());
12241 return 0;
12242 }
12243
12244 return result;
12245 }
12246
12247 static std::string ada_exception_catchpoint_cond_string
12248 (const char *excep_string,
12249 enum ada_exception_catchpoint_kind ex);
12250
12251 /* Ada catchpoints.
12252
12253 In the case of catchpoints on Ada exceptions, the catchpoint will
12254 stop the target on every exception the program throws. When a user
12255 specifies the name of a specific exception, we translate this
12256 request into a condition expression (in text form), and then parse
12257 it into an expression stored in each of the catchpoint's locations.
12258 We then use this condition to check whether the exception that was
12259 raised is the one the user is interested in. If not, then the
12260 target is resumed again. We store the name of the requested
12261 exception, in order to be able to re-set the condition expression
12262 when symbols change. */
12263
12264 /* An instance of this type is used to represent an Ada catchpoint
12265 breakpoint location. */
12266
12267 class ada_catchpoint_location : public bp_location
12268 {
12269 public:
12270 ada_catchpoint_location (breakpoint *owner)
12271 : bp_location (owner)
12272 {}
12273
12274 /* The condition that checks whether the exception that was raised
12275 is the specific exception the user specified on catchpoint
12276 creation. */
12277 expression_up excep_cond_expr;
12278 };
12279
12280 /* An instance of this type is used to represent an Ada catchpoint. */
12281
12282 struct ada_catchpoint : public breakpoint
12283 {
12284 /* The name of the specific exception the user specified. */
12285 std::string excep_string;
12286 };
12287
12288 /* Parse the exception condition string in the context of each of the
12289 catchpoint's locations, and store them for later evaluation. */
12290
12291 static void
12292 create_excep_cond_exprs (struct ada_catchpoint *c,
12293 enum ada_exception_catchpoint_kind ex)
12294 {
12295 /* Nothing to do if there's no specific exception to catch. */
12296 if (c->excep_string.empty ())
12297 return;
12298
12299 /* Same if there are no locations... */
12300 if (c->loc == NULL)
12301 return;
12302
12303 /* We have to compute the expression once for each program space,
12304 because the expression may hold the addresses of multiple symbols
12305 in some cases. */
12306 std::multimap<program_space *, struct bp_location *> loc_map;
12307 for (bp_location *bl = c->loc; bl != NULL; bl = bl->next)
12308 loc_map.emplace (bl->pspace, bl);
12309
12310 scoped_restore_current_program_space save_pspace;
12311
12312 std::string cond_string;
12313 program_space *last_ps = nullptr;
12314 for (auto iter : loc_map)
12315 {
12316 struct ada_catchpoint_location *ada_loc
12317 = (struct ada_catchpoint_location *) iter.second;
12318
12319 if (ada_loc->pspace != last_ps)
12320 {
12321 last_ps = ada_loc->pspace;
12322 set_current_program_space (last_ps);
12323
12324 /* Compute the condition expression in text form, from the
12325 specific expection we want to catch. */
12326 cond_string
12327 = ada_exception_catchpoint_cond_string (c->excep_string.c_str (),
12328 ex);
12329 }
12330
12331 expression_up exp;
12332
12333 if (!ada_loc->shlib_disabled)
12334 {
12335 const char *s;
12336
12337 s = cond_string.c_str ();
12338 try
12339 {
12340 exp = parse_exp_1 (&s, ada_loc->address,
12341 block_for_pc (ada_loc->address),
12342 0);
12343 }
12344 catch (const gdb_exception_error &e)
12345 {
12346 warning (_("failed to reevaluate internal exception condition "
12347 "for catchpoint %d: %s"),
12348 c->number, e.what ());
12349 }
12350 }
12351
12352 ada_loc->excep_cond_expr = std::move (exp);
12353 }
12354 }
12355
12356 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12357 structure for all exception catchpoint kinds. */
12358
12359 static struct bp_location *
12360 allocate_location_exception (enum ada_exception_catchpoint_kind ex,
12361 struct breakpoint *self)
12362 {
12363 return new ada_catchpoint_location (self);
12364 }
12365
12366 /* Implement the RE_SET method in the breakpoint_ops structure for all
12367 exception catchpoint kinds. */
12368
12369 static void
12370 re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
12371 {
12372 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12373
12374 /* Call the base class's method. This updates the catchpoint's
12375 locations. */
12376 bkpt_breakpoint_ops.re_set (b);
12377
12378 /* Reparse the exception conditional expressions. One for each
12379 location. */
12380 create_excep_cond_exprs (c, ex);
12381 }
12382
12383 /* Returns true if we should stop for this breakpoint hit. If the
12384 user specified a specific exception, we only want to cause a stop
12385 if the program thrown that exception. */
12386
12387 static int
12388 should_stop_exception (const struct bp_location *bl)
12389 {
12390 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12391 const struct ada_catchpoint_location *ada_loc
12392 = (const struct ada_catchpoint_location *) bl;
12393 int stop;
12394
12395 /* With no specific exception, should always stop. */
12396 if (c->excep_string.empty ())
12397 return 1;
12398
12399 if (ada_loc->excep_cond_expr == NULL)
12400 {
12401 /* We will have a NULL expression if back when we were creating
12402 the expressions, this location's had failed to parse. */
12403 return 1;
12404 }
12405
12406 stop = 1;
12407 try
12408 {
12409 struct value *mark;
12410
12411 mark = value_mark ();
12412 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12413 value_free_to_mark (mark);
12414 }
12415 catch (const gdb_exception &ex)
12416 {
12417 exception_fprintf (gdb_stderr, ex,
12418 _("Error in testing exception condition:\n"));
12419 }
12420
12421 return stop;
12422 }
12423
12424 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12425 for all exception catchpoint kinds. */
12426
12427 static void
12428 check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
12429 {
12430 bs->stop = should_stop_exception (bs->bp_location_at);
12431 }
12432
12433 /* Implement the PRINT_IT method in the breakpoint_ops structure
12434 for all exception catchpoint kinds. */
12435
12436 static enum print_stop_action
12437 print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
12438 {
12439 struct ui_out *uiout = current_uiout;
12440 struct breakpoint *b = bs->breakpoint_at;
12441
12442 annotate_catchpoint (b->number);
12443
12444 if (uiout->is_mi_like_p ())
12445 {
12446 uiout->field_string ("reason",
12447 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12448 uiout->field_string ("disp", bpdisp_text (b->disposition));
12449 }
12450
12451 uiout->text (b->disposition == disp_del
12452 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12453 uiout->field_int ("bkptno", b->number);
12454 uiout->text (", ");
12455
12456 /* ada_exception_name_addr relies on the selected frame being the
12457 current frame. Need to do this here because this function may be
12458 called more than once when printing a stop, and below, we'll
12459 select the first frame past the Ada run-time (see
12460 ada_find_printable_frame). */
12461 select_frame (get_current_frame ());
12462
12463 switch (ex)
12464 {
12465 case ada_catch_exception:
12466 case ada_catch_exception_unhandled:
12467 case ada_catch_handlers:
12468 {
12469 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12470 char exception_name[256];
12471
12472 if (addr != 0)
12473 {
12474 read_memory (addr, (gdb_byte *) exception_name,
12475 sizeof (exception_name) - 1);
12476 exception_name [sizeof (exception_name) - 1] = '\0';
12477 }
12478 else
12479 {
12480 /* For some reason, we were unable to read the exception
12481 name. This could happen if the Runtime was compiled
12482 without debugging info, for instance. In that case,
12483 just replace the exception name by the generic string
12484 "exception" - it will read as "an exception" in the
12485 notification we are about to print. */
12486 memcpy (exception_name, "exception", sizeof ("exception"));
12487 }
12488 /* In the case of unhandled exception breakpoints, we print
12489 the exception name as "unhandled EXCEPTION_NAME", to make
12490 it clearer to the user which kind of catchpoint just got
12491 hit. We used ui_out_text to make sure that this extra
12492 info does not pollute the exception name in the MI case. */
12493 if (ex == ada_catch_exception_unhandled)
12494 uiout->text ("unhandled ");
12495 uiout->field_string ("exception-name", exception_name);
12496 }
12497 break;
12498 case ada_catch_assert:
12499 /* In this case, the name of the exception is not really
12500 important. Just print "failed assertion" to make it clearer
12501 that his program just hit an assertion-failure catchpoint.
12502 We used ui_out_text because this info does not belong in
12503 the MI output. */
12504 uiout->text ("failed assertion");
12505 break;
12506 }
12507
12508 gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
12509 if (exception_message != NULL)
12510 {
12511 uiout->text (" (");
12512 uiout->field_string ("exception-message", exception_message.get ());
12513 uiout->text (")");
12514 }
12515
12516 uiout->text (" at ");
12517 ada_find_printable_frame (get_current_frame ());
12518
12519 return PRINT_SRC_AND_LOC;
12520 }
12521
12522 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12523 for all exception catchpoint kinds. */
12524
12525 static void
12526 print_one_exception (enum ada_exception_catchpoint_kind ex,
12527 struct breakpoint *b, struct bp_location **last_loc)
12528 {
12529 struct ui_out *uiout = current_uiout;
12530 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12531 struct value_print_options opts;
12532
12533 get_user_print_options (&opts);
12534 if (opts.addressprint)
12535 {
12536 annotate_field (4);
12537 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
12538 }
12539
12540 annotate_field (5);
12541 *last_loc = b->loc;
12542 switch (ex)
12543 {
12544 case ada_catch_exception:
12545 if (!c->excep_string.empty ())
12546 {
12547 std::string msg = string_printf (_("`%s' Ada exception"),
12548 c->excep_string.c_str ());
12549
12550 uiout->field_string ("what", msg);
12551 }
12552 else
12553 uiout->field_string ("what", "all Ada exceptions");
12554
12555 break;
12556
12557 case ada_catch_exception_unhandled:
12558 uiout->field_string ("what", "unhandled Ada exceptions");
12559 break;
12560
12561 case ada_catch_handlers:
12562 if (!c->excep_string.empty ())
12563 {
12564 uiout->field_fmt ("what",
12565 _("`%s' Ada exception handlers"),
12566 c->excep_string.c_str ());
12567 }
12568 else
12569 uiout->field_string ("what", "all Ada exceptions handlers");
12570 break;
12571
12572 case ada_catch_assert:
12573 uiout->field_string ("what", "failed Ada assertions");
12574 break;
12575
12576 default:
12577 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12578 break;
12579 }
12580 }
12581
12582 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12583 for all exception catchpoint kinds. */
12584
12585 static void
12586 print_mention_exception (enum ada_exception_catchpoint_kind ex,
12587 struct breakpoint *b)
12588 {
12589 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12590 struct ui_out *uiout = current_uiout;
12591
12592 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
12593 : _("Catchpoint "));
12594 uiout->field_int ("bkptno", b->number);
12595 uiout->text (": ");
12596
12597 switch (ex)
12598 {
12599 case ada_catch_exception:
12600 if (!c->excep_string.empty ())
12601 {
12602 std::string info = string_printf (_("`%s' Ada exception"),
12603 c->excep_string.c_str ());
12604 uiout->text (info.c_str ());
12605 }
12606 else
12607 uiout->text (_("all Ada exceptions"));
12608 break;
12609
12610 case ada_catch_exception_unhandled:
12611 uiout->text (_("unhandled Ada exceptions"));
12612 break;
12613
12614 case ada_catch_handlers:
12615 if (!c->excep_string.empty ())
12616 {
12617 std::string info
12618 = string_printf (_("`%s' Ada exception handlers"),
12619 c->excep_string.c_str ());
12620 uiout->text (info.c_str ());
12621 }
12622 else
12623 uiout->text (_("all Ada exceptions handlers"));
12624 break;
12625
12626 case ada_catch_assert:
12627 uiout->text (_("failed Ada assertions"));
12628 break;
12629
12630 default:
12631 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12632 break;
12633 }
12634 }
12635
12636 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12637 for all exception catchpoint kinds. */
12638
12639 static void
12640 print_recreate_exception (enum ada_exception_catchpoint_kind ex,
12641 struct breakpoint *b, struct ui_file *fp)
12642 {
12643 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12644
12645 switch (ex)
12646 {
12647 case ada_catch_exception:
12648 fprintf_filtered (fp, "catch exception");
12649 if (!c->excep_string.empty ())
12650 fprintf_filtered (fp, " %s", c->excep_string.c_str ());
12651 break;
12652
12653 case ada_catch_exception_unhandled:
12654 fprintf_filtered (fp, "catch exception unhandled");
12655 break;
12656
12657 case ada_catch_handlers:
12658 fprintf_filtered (fp, "catch handlers");
12659 break;
12660
12661 case ada_catch_assert:
12662 fprintf_filtered (fp, "catch assert");
12663 break;
12664
12665 default:
12666 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12667 }
12668 print_recreate_thread (b, fp);
12669 }
12670
12671 /* Virtual table for "catch exception" breakpoints. */
12672
12673 static struct bp_location *
12674 allocate_location_catch_exception (struct breakpoint *self)
12675 {
12676 return allocate_location_exception (ada_catch_exception, self);
12677 }
12678
12679 static void
12680 re_set_catch_exception (struct breakpoint *b)
12681 {
12682 re_set_exception (ada_catch_exception, b);
12683 }
12684
12685 static void
12686 check_status_catch_exception (bpstat bs)
12687 {
12688 check_status_exception (ada_catch_exception, bs);
12689 }
12690
12691 static enum print_stop_action
12692 print_it_catch_exception (bpstat bs)
12693 {
12694 return print_it_exception (ada_catch_exception, bs);
12695 }
12696
12697 static void
12698 print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
12699 {
12700 print_one_exception (ada_catch_exception, b, last_loc);
12701 }
12702
12703 static void
12704 print_mention_catch_exception (struct breakpoint *b)
12705 {
12706 print_mention_exception (ada_catch_exception, b);
12707 }
12708
12709 static void
12710 print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12711 {
12712 print_recreate_exception (ada_catch_exception, b, fp);
12713 }
12714
12715 static struct breakpoint_ops catch_exception_breakpoint_ops;
12716
12717 /* Virtual table for "catch exception unhandled" breakpoints. */
12718
12719 static struct bp_location *
12720 allocate_location_catch_exception_unhandled (struct breakpoint *self)
12721 {
12722 return allocate_location_exception (ada_catch_exception_unhandled, self);
12723 }
12724
12725 static void
12726 re_set_catch_exception_unhandled (struct breakpoint *b)
12727 {
12728 re_set_exception (ada_catch_exception_unhandled, b);
12729 }
12730
12731 static void
12732 check_status_catch_exception_unhandled (bpstat bs)
12733 {
12734 check_status_exception (ada_catch_exception_unhandled, bs);
12735 }
12736
12737 static enum print_stop_action
12738 print_it_catch_exception_unhandled (bpstat bs)
12739 {
12740 return print_it_exception (ada_catch_exception_unhandled, bs);
12741 }
12742
12743 static void
12744 print_one_catch_exception_unhandled (struct breakpoint *b,
12745 struct bp_location **last_loc)
12746 {
12747 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
12748 }
12749
12750 static void
12751 print_mention_catch_exception_unhandled (struct breakpoint *b)
12752 {
12753 print_mention_exception (ada_catch_exception_unhandled, b);
12754 }
12755
12756 static void
12757 print_recreate_catch_exception_unhandled (struct breakpoint *b,
12758 struct ui_file *fp)
12759 {
12760 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
12761 }
12762
12763 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
12764
12765 /* Virtual table for "catch assert" breakpoints. */
12766
12767 static struct bp_location *
12768 allocate_location_catch_assert (struct breakpoint *self)
12769 {
12770 return allocate_location_exception (ada_catch_assert, self);
12771 }
12772
12773 static void
12774 re_set_catch_assert (struct breakpoint *b)
12775 {
12776 re_set_exception (ada_catch_assert, b);
12777 }
12778
12779 static void
12780 check_status_catch_assert (bpstat bs)
12781 {
12782 check_status_exception (ada_catch_assert, bs);
12783 }
12784
12785 static enum print_stop_action
12786 print_it_catch_assert (bpstat bs)
12787 {
12788 return print_it_exception (ada_catch_assert, bs);
12789 }
12790
12791 static void
12792 print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
12793 {
12794 print_one_exception (ada_catch_assert, b, last_loc);
12795 }
12796
12797 static void
12798 print_mention_catch_assert (struct breakpoint *b)
12799 {
12800 print_mention_exception (ada_catch_assert, b);
12801 }
12802
12803 static void
12804 print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12805 {
12806 print_recreate_exception (ada_catch_assert, b, fp);
12807 }
12808
12809 static struct breakpoint_ops catch_assert_breakpoint_ops;
12810
12811 /* Virtual table for "catch handlers" breakpoints. */
12812
12813 static struct bp_location *
12814 allocate_location_catch_handlers (struct breakpoint *self)
12815 {
12816 return allocate_location_exception (ada_catch_handlers, self);
12817 }
12818
12819 static void
12820 re_set_catch_handlers (struct breakpoint *b)
12821 {
12822 re_set_exception (ada_catch_handlers, b);
12823 }
12824
12825 static void
12826 check_status_catch_handlers (bpstat bs)
12827 {
12828 check_status_exception (ada_catch_handlers, bs);
12829 }
12830
12831 static enum print_stop_action
12832 print_it_catch_handlers (bpstat bs)
12833 {
12834 return print_it_exception (ada_catch_handlers, bs);
12835 }
12836
12837 static void
12838 print_one_catch_handlers (struct breakpoint *b,
12839 struct bp_location **last_loc)
12840 {
12841 print_one_exception (ada_catch_handlers, b, last_loc);
12842 }
12843
12844 static void
12845 print_mention_catch_handlers (struct breakpoint *b)
12846 {
12847 print_mention_exception (ada_catch_handlers, b);
12848 }
12849
12850 static void
12851 print_recreate_catch_handlers (struct breakpoint *b,
12852 struct ui_file *fp)
12853 {
12854 print_recreate_exception (ada_catch_handlers, b, fp);
12855 }
12856
12857 static struct breakpoint_ops catch_handlers_breakpoint_ops;
12858
12859 /* Split the arguments specified in a "catch exception" command.
12860 Set EX to the appropriate catchpoint type.
12861 Set EXCEP_STRING to the name of the specific exception if
12862 specified by the user.
12863 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12864 "catch handlers" command. False otherwise.
12865 If a condition is found at the end of the arguments, the condition
12866 expression is stored in COND_STRING (memory must be deallocated
12867 after use). Otherwise COND_STRING is set to NULL. */
12868
12869 static void
12870 catch_ada_exception_command_split (const char *args,
12871 bool is_catch_handlers_cmd,
12872 enum ada_exception_catchpoint_kind *ex,
12873 std::string *excep_string,
12874 std::string *cond_string)
12875 {
12876 std::string exception_name;
12877
12878 exception_name = extract_arg (&args);
12879 if (exception_name == "if")
12880 {
12881 /* This is not an exception name; this is the start of a condition
12882 expression for a catchpoint on all exceptions. So, "un-get"
12883 this token, and set exception_name to NULL. */
12884 exception_name.clear ();
12885 args -= 2;
12886 }
12887
12888 /* Check to see if we have a condition. */
12889
12890 args = skip_spaces (args);
12891 if (startswith (args, "if")
12892 && (isspace (args[2]) || args[2] == '\0'))
12893 {
12894 args += 2;
12895 args = skip_spaces (args);
12896
12897 if (args[0] == '\0')
12898 error (_("Condition missing after `if' keyword"));
12899 *cond_string = args;
12900
12901 args += strlen (args);
12902 }
12903
12904 /* Check that we do not have any more arguments. Anything else
12905 is unexpected. */
12906
12907 if (args[0] != '\0')
12908 error (_("Junk at end of expression"));
12909
12910 if (is_catch_handlers_cmd)
12911 {
12912 /* Catch handling of exceptions. */
12913 *ex = ada_catch_handlers;
12914 *excep_string = exception_name;
12915 }
12916 else if (exception_name.empty ())
12917 {
12918 /* Catch all exceptions. */
12919 *ex = ada_catch_exception;
12920 excep_string->clear ();
12921 }
12922 else if (exception_name == "unhandled")
12923 {
12924 /* Catch unhandled exceptions. */
12925 *ex = ada_catch_exception_unhandled;
12926 excep_string->clear ();
12927 }
12928 else
12929 {
12930 /* Catch a specific exception. */
12931 *ex = ada_catch_exception;
12932 *excep_string = exception_name;
12933 }
12934 }
12935
12936 /* Return the name of the symbol on which we should break in order to
12937 implement a catchpoint of the EX kind. */
12938
12939 static const char *
12940 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12941 {
12942 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12943
12944 gdb_assert (data->exception_info != NULL);
12945
12946 switch (ex)
12947 {
12948 case ada_catch_exception:
12949 return (data->exception_info->catch_exception_sym);
12950 break;
12951 case ada_catch_exception_unhandled:
12952 return (data->exception_info->catch_exception_unhandled_sym);
12953 break;
12954 case ada_catch_assert:
12955 return (data->exception_info->catch_assert_sym);
12956 break;
12957 case ada_catch_handlers:
12958 return (data->exception_info->catch_handlers_sym);
12959 break;
12960 default:
12961 internal_error (__FILE__, __LINE__,
12962 _("unexpected catchpoint kind (%d)"), ex);
12963 }
12964 }
12965
12966 /* Return the breakpoint ops "virtual table" used for catchpoints
12967 of the EX kind. */
12968
12969 static const struct breakpoint_ops *
12970 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
12971 {
12972 switch (ex)
12973 {
12974 case ada_catch_exception:
12975 return (&catch_exception_breakpoint_ops);
12976 break;
12977 case ada_catch_exception_unhandled:
12978 return (&catch_exception_unhandled_breakpoint_ops);
12979 break;
12980 case ada_catch_assert:
12981 return (&catch_assert_breakpoint_ops);
12982 break;
12983 case ada_catch_handlers:
12984 return (&catch_handlers_breakpoint_ops);
12985 break;
12986 default:
12987 internal_error (__FILE__, __LINE__,
12988 _("unexpected catchpoint kind (%d)"), ex);
12989 }
12990 }
12991
12992 /* Return the condition that will be used to match the current exception
12993 being raised with the exception that the user wants to catch. This
12994 assumes that this condition is used when the inferior just triggered
12995 an exception catchpoint.
12996 EX: the type of catchpoints used for catching Ada exceptions. */
12997
12998 static std::string
12999 ada_exception_catchpoint_cond_string (const char *excep_string,
13000 enum ada_exception_catchpoint_kind ex)
13001 {
13002 int i;
13003 std::string result;
13004 const char *name;
13005
13006 if (ex == ada_catch_handlers)
13007 {
13008 /* For exception handlers catchpoints, the condition string does
13009 not use the same parameter as for the other exceptions. */
13010 name = ("long_integer (GNAT_GCC_exception_Access"
13011 "(gcc_exception).all.occurrence.id)");
13012 }
13013 else
13014 name = "long_integer (e)";
13015
13016 /* The standard exceptions are a special case. They are defined in
13017 runtime units that have been compiled without debugging info; if
13018 EXCEP_STRING is the not-fully-qualified name of a standard
13019 exception (e.g. "constraint_error") then, during the evaluation
13020 of the condition expression, the symbol lookup on this name would
13021 *not* return this standard exception. The catchpoint condition
13022 may then be set only on user-defined exceptions which have the
13023 same not-fully-qualified name (e.g. my_package.constraint_error).
13024
13025 To avoid this unexcepted behavior, these standard exceptions are
13026 systematically prefixed by "standard". This means that "catch
13027 exception constraint_error" is rewritten into "catch exception
13028 standard.constraint_error".
13029
13030 If an exception named contraint_error is defined in another package of
13031 the inferior program, then the only way to specify this exception as a
13032 breakpoint condition is to use its fully-qualified named:
13033 e.g. my_package.constraint_error.
13034
13035 Furthermore, in some situations a standard exception's symbol may
13036 be present in more than one objfile, because the compiler may
13037 choose to emit copy relocations for them. So, we have to compare
13038 against all the possible addresses. */
13039
13040 /* Storage for a rewritten symbol name. */
13041 std::string std_name;
13042 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
13043 {
13044 if (strcmp (standard_exc [i], excep_string) == 0)
13045 {
13046 std_name = std::string ("standard.") + excep_string;
13047 excep_string = std_name.c_str ();
13048 break;
13049 }
13050 }
13051
13052 excep_string = ada_encode (excep_string);
13053 std::vector<struct bound_minimal_symbol> symbols
13054 = ada_lookup_simple_minsyms (excep_string);
13055 for (const bound_minimal_symbol &msym : symbols)
13056 {
13057 if (!result.empty ())
13058 result += " or ";
13059 string_appendf (result, "%s = %s", name,
13060 pulongest (BMSYMBOL_VALUE_ADDRESS (msym)));
13061 }
13062
13063 return result;
13064 }
13065
13066 /* Return the symtab_and_line that should be used to insert an exception
13067 catchpoint of the TYPE kind.
13068
13069 ADDR_STRING returns the name of the function where the real
13070 breakpoint that implements the catchpoints is set, depending on the
13071 type of catchpoint we need to create. */
13072
13073 static struct symtab_and_line
13074 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
13075 std::string *addr_string, const struct breakpoint_ops **ops)
13076 {
13077 const char *sym_name;
13078 struct symbol *sym;
13079
13080 /* First, find out which exception support info to use. */
13081 ada_exception_support_info_sniffer ();
13082
13083 /* Then lookup the function on which we will break in order to catch
13084 the Ada exceptions requested by the user. */
13085 sym_name = ada_exception_sym_name (ex);
13086 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
13087
13088 if (sym == NULL)
13089 error (_("Catchpoint symbol not found: %s"), sym_name);
13090
13091 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
13092 error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
13093
13094 /* Set ADDR_STRING. */
13095 *addr_string = sym_name;
13096
13097 /* Set OPS. */
13098 *ops = ada_exception_breakpoint_ops (ex);
13099
13100 return find_function_start_sal (sym, 1);
13101 }
13102
13103 /* Create an Ada exception catchpoint.
13104
13105 EX_KIND is the kind of exception catchpoint to be created.
13106
13107 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
13108 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
13109 of the exception to which this catchpoint applies.
13110
13111 COND_STRING, if not empty, is the catchpoint condition.
13112
13113 TEMPFLAG, if nonzero, means that the underlying breakpoint
13114 should be temporary.
13115
13116 FROM_TTY is the usual argument passed to all commands implementations. */
13117
13118 void
13119 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
13120 enum ada_exception_catchpoint_kind ex_kind,
13121 const std::string &excep_string,
13122 const std::string &cond_string,
13123 int tempflag,
13124 int disabled,
13125 int from_tty)
13126 {
13127 std::string addr_string;
13128 const struct breakpoint_ops *ops = NULL;
13129 struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
13130
13131 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
13132 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (),
13133 ops, tempflag, disabled, from_tty);
13134 c->excep_string = excep_string;
13135 create_excep_cond_exprs (c.get (), ex_kind);
13136 if (!cond_string.empty ())
13137 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty);
13138 install_breakpoint (0, std::move (c), 1);
13139 }
13140
13141 /* Implement the "catch exception" command. */
13142
13143 static void
13144 catch_ada_exception_command (const char *arg_entry, int from_tty,
13145 struct cmd_list_element *command)
13146 {
13147 const char *arg = arg_entry;
13148 struct gdbarch *gdbarch = get_current_arch ();
13149 int tempflag;
13150 enum ada_exception_catchpoint_kind ex_kind;
13151 std::string excep_string;
13152 std::string cond_string;
13153
13154 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13155
13156 if (!arg)
13157 arg = "";
13158 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
13159 &cond_string);
13160 create_ada_exception_catchpoint (gdbarch, ex_kind,
13161 excep_string, cond_string,
13162 tempflag, 1 /* enabled */,
13163 from_tty);
13164 }
13165
13166 /* Implement the "catch handlers" command. */
13167
13168 static void
13169 catch_ada_handlers_command (const char *arg_entry, int from_tty,
13170 struct cmd_list_element *command)
13171 {
13172 const char *arg = arg_entry;
13173 struct gdbarch *gdbarch = get_current_arch ();
13174 int tempflag;
13175 enum ada_exception_catchpoint_kind ex_kind;
13176 std::string excep_string;
13177 std::string cond_string;
13178
13179 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13180
13181 if (!arg)
13182 arg = "";
13183 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
13184 &cond_string);
13185 create_ada_exception_catchpoint (gdbarch, ex_kind,
13186 excep_string, cond_string,
13187 tempflag, 1 /* enabled */,
13188 from_tty);
13189 }
13190
13191 /* Completion function for the Ada "catch" commands. */
13192
13193 static void
13194 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
13195 const char *text, const char *word)
13196 {
13197 std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
13198
13199 for (const ada_exc_info &info : exceptions)
13200 {
13201 if (startswith (info.name, word))
13202 tracker.add_completion (make_unique_xstrdup (info.name));
13203 }
13204 }
13205
13206 /* Split the arguments specified in a "catch assert" command.
13207
13208 ARGS contains the command's arguments (or the empty string if
13209 no arguments were passed).
13210
13211 If ARGS contains a condition, set COND_STRING to that condition
13212 (the memory needs to be deallocated after use). */
13213
13214 static void
13215 catch_ada_assert_command_split (const char *args, std::string &cond_string)
13216 {
13217 args = skip_spaces (args);
13218
13219 /* Check whether a condition was provided. */
13220 if (startswith (args, "if")
13221 && (isspace (args[2]) || args[2] == '\0'))
13222 {
13223 args += 2;
13224 args = skip_spaces (args);
13225 if (args[0] == '\0')
13226 error (_("condition missing after `if' keyword"));
13227 cond_string.assign (args);
13228 }
13229
13230 /* Otherwise, there should be no other argument at the end of
13231 the command. */
13232 else if (args[0] != '\0')
13233 error (_("Junk at end of arguments."));
13234 }
13235
13236 /* Implement the "catch assert" command. */
13237
13238 static void
13239 catch_assert_command (const char *arg_entry, int from_tty,
13240 struct cmd_list_element *command)
13241 {
13242 const char *arg = arg_entry;
13243 struct gdbarch *gdbarch = get_current_arch ();
13244 int tempflag;
13245 std::string cond_string;
13246
13247 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13248
13249 if (!arg)
13250 arg = "";
13251 catch_ada_assert_command_split (arg, cond_string);
13252 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
13253 "", cond_string,
13254 tempflag, 1 /* enabled */,
13255 from_tty);
13256 }
13257
13258 /* Return non-zero if the symbol SYM is an Ada exception object. */
13259
13260 static int
13261 ada_is_exception_sym (struct symbol *sym)
13262 {
13263 const char *type_name = TYPE_NAME (SYMBOL_TYPE (sym));
13264
13265 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13266 && SYMBOL_CLASS (sym) != LOC_BLOCK
13267 && SYMBOL_CLASS (sym) != LOC_CONST
13268 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13269 && type_name != NULL && strcmp (type_name, "exception") == 0);
13270 }
13271
13272 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13273 Ada exception object. This matches all exceptions except the ones
13274 defined by the Ada language. */
13275
13276 static int
13277 ada_is_non_standard_exception_sym (struct symbol *sym)
13278 {
13279 int i;
13280
13281 if (!ada_is_exception_sym (sym))
13282 return 0;
13283
13284 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13285 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13286 return 0; /* A standard exception. */
13287
13288 /* Numeric_Error is also a standard exception, so exclude it.
13289 See the STANDARD_EXC description for more details as to why
13290 this exception is not listed in that array. */
13291 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13292 return 0;
13293
13294 return 1;
13295 }
13296
13297 /* A helper function for std::sort, comparing two struct ada_exc_info
13298 objects.
13299
13300 The comparison is determined first by exception name, and then
13301 by exception address. */
13302
13303 bool
13304 ada_exc_info::operator< (const ada_exc_info &other) const
13305 {
13306 int result;
13307
13308 result = strcmp (name, other.name);
13309 if (result < 0)
13310 return true;
13311 if (result == 0 && addr < other.addr)
13312 return true;
13313 return false;
13314 }
13315
13316 bool
13317 ada_exc_info::operator== (const ada_exc_info &other) const
13318 {
13319 return addr == other.addr && strcmp (name, other.name) == 0;
13320 }
13321
13322 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13323 routine, but keeping the first SKIP elements untouched.
13324
13325 All duplicates are also removed. */
13326
13327 static void
13328 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
13329 int skip)
13330 {
13331 std::sort (exceptions->begin () + skip, exceptions->end ());
13332 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13333 exceptions->end ());
13334 }
13335
13336 /* Add all exceptions defined by the Ada standard whose name match
13337 a regular expression.
13338
13339 If PREG is not NULL, then this regexp_t object is used to
13340 perform the symbol name matching. Otherwise, no name-based
13341 filtering is performed.
13342
13343 EXCEPTIONS is a vector of exceptions to which matching exceptions
13344 gets pushed. */
13345
13346 static void
13347 ada_add_standard_exceptions (compiled_regex *preg,
13348 std::vector<ada_exc_info> *exceptions)
13349 {
13350 int i;
13351
13352 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13353 {
13354 if (preg == NULL
13355 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
13356 {
13357 struct bound_minimal_symbol msymbol
13358 = ada_lookup_simple_minsym (standard_exc[i]);
13359
13360 if (msymbol.minsym != NULL)
13361 {
13362 struct ada_exc_info info
13363 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
13364
13365 exceptions->push_back (info);
13366 }
13367 }
13368 }
13369 }
13370
13371 /* Add all Ada exceptions defined locally and accessible from the given
13372 FRAME.
13373
13374 If PREG is not NULL, then this regexp_t object is used to
13375 perform the symbol name matching. Otherwise, no name-based
13376 filtering is performed.
13377
13378 EXCEPTIONS is a vector of exceptions to which matching exceptions
13379 gets pushed. */
13380
13381 static void
13382 ada_add_exceptions_from_frame (compiled_regex *preg,
13383 struct frame_info *frame,
13384 std::vector<ada_exc_info> *exceptions)
13385 {
13386 const struct block *block = get_frame_block (frame, 0);
13387
13388 while (block != 0)
13389 {
13390 struct block_iterator iter;
13391 struct symbol *sym;
13392
13393 ALL_BLOCK_SYMBOLS (block, iter, sym)
13394 {
13395 switch (SYMBOL_CLASS (sym))
13396 {
13397 case LOC_TYPEDEF:
13398 case LOC_BLOCK:
13399 case LOC_CONST:
13400 break;
13401 default:
13402 if (ada_is_exception_sym (sym))
13403 {
13404 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13405 SYMBOL_VALUE_ADDRESS (sym)};
13406
13407 exceptions->push_back (info);
13408 }
13409 }
13410 }
13411 if (BLOCK_FUNCTION (block) != NULL)
13412 break;
13413 block = BLOCK_SUPERBLOCK (block);
13414 }
13415 }
13416
13417 /* Return true if NAME matches PREG or if PREG is NULL. */
13418
13419 static bool
13420 name_matches_regex (const char *name, compiled_regex *preg)
13421 {
13422 return (preg == NULL
13423 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
13424 }
13425
13426 /* Add all exceptions defined globally whose name name match
13427 a regular expression, excluding standard exceptions.
13428
13429 The reason we exclude standard exceptions is that they need
13430 to be handled separately: Standard exceptions are defined inside
13431 a runtime unit which is normally not compiled with debugging info,
13432 and thus usually do not show up in our symbol search. However,
13433 if the unit was in fact built with debugging info, we need to
13434 exclude them because they would duplicate the entry we found
13435 during the special loop that specifically searches for those
13436 standard exceptions.
13437
13438 If PREG is not NULL, then this regexp_t object is used to
13439 perform the symbol name matching. Otherwise, no name-based
13440 filtering is performed.
13441
13442 EXCEPTIONS is a vector of exceptions to which matching exceptions
13443 gets pushed. */
13444
13445 static void
13446 ada_add_global_exceptions (compiled_regex *preg,
13447 std::vector<ada_exc_info> *exceptions)
13448 {
13449 /* In Ada, the symbol "search name" is a linkage name, whereas the
13450 regular expression used to do the matching refers to the natural
13451 name. So match against the decoded name. */
13452 expand_symtabs_matching (NULL,
13453 lookup_name_info::match_any (),
13454 [&] (const char *search_name)
13455 {
13456 const char *decoded = ada_decode (search_name);
13457 return name_matches_regex (decoded, preg);
13458 },
13459 NULL,
13460 VARIABLES_DOMAIN);
13461
13462 for (objfile *objfile : current_program_space->objfiles ())
13463 {
13464 for (compunit_symtab *s : objfile->compunits ())
13465 {
13466 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
13467 int i;
13468
13469 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13470 {
13471 const struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13472 struct block_iterator iter;
13473 struct symbol *sym;
13474
13475 ALL_BLOCK_SYMBOLS (b, iter, sym)
13476 if (ada_is_non_standard_exception_sym (sym)
13477 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
13478 {
13479 struct ada_exc_info info
13480 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13481
13482 exceptions->push_back (info);
13483 }
13484 }
13485 }
13486 }
13487 }
13488
13489 /* Implements ada_exceptions_list with the regular expression passed
13490 as a regex_t, rather than a string.
13491
13492 If not NULL, PREG is used to filter out exceptions whose names
13493 do not match. Otherwise, all exceptions are listed. */
13494
13495 static std::vector<ada_exc_info>
13496 ada_exceptions_list_1 (compiled_regex *preg)
13497 {
13498 std::vector<ada_exc_info> result;
13499 int prev_len;
13500
13501 /* First, list the known standard exceptions. These exceptions
13502 need to be handled separately, as they are usually defined in
13503 runtime units that have been compiled without debugging info. */
13504
13505 ada_add_standard_exceptions (preg, &result);
13506
13507 /* Next, find all exceptions whose scope is local and accessible
13508 from the currently selected frame. */
13509
13510 if (has_stack_frames ())
13511 {
13512 prev_len = result.size ();
13513 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13514 &result);
13515 if (result.size () > prev_len)
13516 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13517 }
13518
13519 /* Add all exceptions whose scope is global. */
13520
13521 prev_len = result.size ();
13522 ada_add_global_exceptions (preg, &result);
13523 if (result.size () > prev_len)
13524 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13525
13526 return result;
13527 }
13528
13529 /* Return a vector of ada_exc_info.
13530
13531 If REGEXP is NULL, all exceptions are included in the result.
13532 Otherwise, it should contain a valid regular expression,
13533 and only the exceptions whose names match that regular expression
13534 are included in the result.
13535
13536 The exceptions are sorted in the following order:
13537 - Standard exceptions (defined by the Ada language), in
13538 alphabetical order;
13539 - Exceptions only visible from the current frame, in
13540 alphabetical order;
13541 - Exceptions whose scope is global, in alphabetical order. */
13542
13543 std::vector<ada_exc_info>
13544 ada_exceptions_list (const char *regexp)
13545 {
13546 if (regexp == NULL)
13547 return ada_exceptions_list_1 (NULL);
13548
13549 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13550 return ada_exceptions_list_1 (&reg);
13551 }
13552
13553 /* Implement the "info exceptions" command. */
13554
13555 static void
13556 info_exceptions_command (const char *regexp, int from_tty)
13557 {
13558 struct gdbarch *gdbarch = get_current_arch ();
13559
13560 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13561
13562 if (regexp != NULL)
13563 printf_filtered
13564 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13565 else
13566 printf_filtered (_("All defined Ada exceptions:\n"));
13567
13568 for (const ada_exc_info &info : exceptions)
13569 printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13570 }
13571
13572 /* Operators */
13573 /* Information about operators given special treatment in functions
13574 below. */
13575 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13576
13577 #define ADA_OPERATORS \
13578 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13579 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13580 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13581 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13582 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13583 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13584 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13585 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13586 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13587 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13588 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13589 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13590 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13591 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13592 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13593 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13594 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13595 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13596 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13597
13598 static void
13599 ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13600 int *argsp)
13601 {
13602 switch (exp->elts[pc - 1].opcode)
13603 {
13604 default:
13605 operator_length_standard (exp, pc, oplenp, argsp);
13606 break;
13607
13608 #define OP_DEFN(op, len, args, binop) \
13609 case op: *oplenp = len; *argsp = args; break;
13610 ADA_OPERATORS;
13611 #undef OP_DEFN
13612
13613 case OP_AGGREGATE:
13614 *oplenp = 3;
13615 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13616 break;
13617
13618 case OP_CHOICES:
13619 *oplenp = 3;
13620 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13621 break;
13622 }
13623 }
13624
13625 /* Implementation of the exp_descriptor method operator_check. */
13626
13627 static int
13628 ada_operator_check (struct expression *exp, int pos,
13629 int (*objfile_func) (struct objfile *objfile, void *data),
13630 void *data)
13631 {
13632 const union exp_element *const elts = exp->elts;
13633 struct type *type = NULL;
13634
13635 switch (elts[pos].opcode)
13636 {
13637 case UNOP_IN_RANGE:
13638 case UNOP_QUAL:
13639 type = elts[pos + 1].type;
13640 break;
13641
13642 default:
13643 return operator_check_standard (exp, pos, objfile_func, data);
13644 }
13645
13646 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13647
13648 if (type && TYPE_OBJFILE (type)
13649 && (*objfile_func) (TYPE_OBJFILE (type), data))
13650 return 1;
13651
13652 return 0;
13653 }
13654
13655 static const char *
13656 ada_op_name (enum exp_opcode opcode)
13657 {
13658 switch (opcode)
13659 {
13660 default:
13661 return op_name_standard (opcode);
13662
13663 #define OP_DEFN(op, len, args, binop) case op: return #op;
13664 ADA_OPERATORS;
13665 #undef OP_DEFN
13666
13667 case OP_AGGREGATE:
13668 return "OP_AGGREGATE";
13669 case OP_CHOICES:
13670 return "OP_CHOICES";
13671 case OP_NAME:
13672 return "OP_NAME";
13673 }
13674 }
13675
13676 /* As for operator_length, but assumes PC is pointing at the first
13677 element of the operator, and gives meaningful results only for the
13678 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13679
13680 static void
13681 ada_forward_operator_length (struct expression *exp, int pc,
13682 int *oplenp, int *argsp)
13683 {
13684 switch (exp->elts[pc].opcode)
13685 {
13686 default:
13687 *oplenp = *argsp = 0;
13688 break;
13689
13690 #define OP_DEFN(op, len, args, binop) \
13691 case op: *oplenp = len; *argsp = args; break;
13692 ADA_OPERATORS;
13693 #undef OP_DEFN
13694
13695 case OP_AGGREGATE:
13696 *oplenp = 3;
13697 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13698 break;
13699
13700 case OP_CHOICES:
13701 *oplenp = 3;
13702 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13703 break;
13704
13705 case OP_STRING:
13706 case OP_NAME:
13707 {
13708 int len = longest_to_int (exp->elts[pc + 1].longconst);
13709
13710 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13711 *argsp = 0;
13712 break;
13713 }
13714 }
13715 }
13716
13717 static int
13718 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13719 {
13720 enum exp_opcode op = exp->elts[elt].opcode;
13721 int oplen, nargs;
13722 int pc = elt;
13723 int i;
13724
13725 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13726
13727 switch (op)
13728 {
13729 /* Ada attributes ('Foo). */
13730 case OP_ATR_FIRST:
13731 case OP_ATR_LAST:
13732 case OP_ATR_LENGTH:
13733 case OP_ATR_IMAGE:
13734 case OP_ATR_MAX:
13735 case OP_ATR_MIN:
13736 case OP_ATR_MODULUS:
13737 case OP_ATR_POS:
13738 case OP_ATR_SIZE:
13739 case OP_ATR_TAG:
13740 case OP_ATR_VAL:
13741 break;
13742
13743 case UNOP_IN_RANGE:
13744 case UNOP_QUAL:
13745 /* XXX: gdb_sprint_host_address, type_sprint */
13746 fprintf_filtered (stream, _("Type @"));
13747 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13748 fprintf_filtered (stream, " (");
13749 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13750 fprintf_filtered (stream, ")");
13751 break;
13752 case BINOP_IN_BOUNDS:
13753 fprintf_filtered (stream, " (%d)",
13754 longest_to_int (exp->elts[pc + 2].longconst));
13755 break;
13756 case TERNOP_IN_RANGE:
13757 break;
13758
13759 case OP_AGGREGATE:
13760 case OP_OTHERS:
13761 case OP_DISCRETE_RANGE:
13762 case OP_POSITIONAL:
13763 case OP_CHOICES:
13764 break;
13765
13766 case OP_NAME:
13767 case OP_STRING:
13768 {
13769 char *name = &exp->elts[elt + 2].string;
13770 int len = longest_to_int (exp->elts[elt + 1].longconst);
13771
13772 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13773 break;
13774 }
13775
13776 default:
13777 return dump_subexp_body_standard (exp, stream, elt);
13778 }
13779
13780 elt += oplen;
13781 for (i = 0; i < nargs; i += 1)
13782 elt = dump_subexp (exp, stream, elt);
13783
13784 return elt;
13785 }
13786
13787 /* The Ada extension of print_subexp (q.v.). */
13788
13789 static void
13790 ada_print_subexp (struct expression *exp, int *pos,
13791 struct ui_file *stream, enum precedence prec)
13792 {
13793 int oplen, nargs, i;
13794 int pc = *pos;
13795 enum exp_opcode op = exp->elts[pc].opcode;
13796
13797 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13798
13799 *pos += oplen;
13800 switch (op)
13801 {
13802 default:
13803 *pos -= oplen;
13804 print_subexp_standard (exp, pos, stream, prec);
13805 return;
13806
13807 case OP_VAR_VALUE:
13808 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13809 return;
13810
13811 case BINOP_IN_BOUNDS:
13812 /* XXX: sprint_subexp */
13813 print_subexp (exp, pos, stream, PREC_SUFFIX);
13814 fputs_filtered (" in ", stream);
13815 print_subexp (exp, pos, stream, PREC_SUFFIX);
13816 fputs_filtered ("'range", stream);
13817 if (exp->elts[pc + 1].longconst > 1)
13818 fprintf_filtered (stream, "(%ld)",
13819 (long) exp->elts[pc + 1].longconst);
13820 return;
13821
13822 case TERNOP_IN_RANGE:
13823 if (prec >= PREC_EQUAL)
13824 fputs_filtered ("(", stream);
13825 /* XXX: sprint_subexp */
13826 print_subexp (exp, pos, stream, PREC_SUFFIX);
13827 fputs_filtered (" in ", stream);
13828 print_subexp (exp, pos, stream, PREC_EQUAL);
13829 fputs_filtered (" .. ", stream);
13830 print_subexp (exp, pos, stream, PREC_EQUAL);
13831 if (prec >= PREC_EQUAL)
13832 fputs_filtered (")", stream);
13833 return;
13834
13835 case OP_ATR_FIRST:
13836 case OP_ATR_LAST:
13837 case OP_ATR_LENGTH:
13838 case OP_ATR_IMAGE:
13839 case OP_ATR_MAX:
13840 case OP_ATR_MIN:
13841 case OP_ATR_MODULUS:
13842 case OP_ATR_POS:
13843 case OP_ATR_SIZE:
13844 case OP_ATR_TAG:
13845 case OP_ATR_VAL:
13846 if (exp->elts[*pos].opcode == OP_TYPE)
13847 {
13848 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
13849 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13850 &type_print_raw_options);
13851 *pos += 3;
13852 }
13853 else
13854 print_subexp (exp, pos, stream, PREC_SUFFIX);
13855 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13856 if (nargs > 1)
13857 {
13858 int tem;
13859
13860 for (tem = 1; tem < nargs; tem += 1)
13861 {
13862 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13863 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13864 }
13865 fputs_filtered (")", stream);
13866 }
13867 return;
13868
13869 case UNOP_QUAL:
13870 type_print (exp->elts[pc + 1].type, "", stream, 0);
13871 fputs_filtered ("'(", stream);
13872 print_subexp (exp, pos, stream, PREC_PREFIX);
13873 fputs_filtered (")", stream);
13874 return;
13875
13876 case UNOP_IN_RANGE:
13877 /* XXX: sprint_subexp */
13878 print_subexp (exp, pos, stream, PREC_SUFFIX);
13879 fputs_filtered (" in ", stream);
13880 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13881 &type_print_raw_options);
13882 return;
13883
13884 case OP_DISCRETE_RANGE:
13885 print_subexp (exp, pos, stream, PREC_SUFFIX);
13886 fputs_filtered ("..", stream);
13887 print_subexp (exp, pos, stream, PREC_SUFFIX);
13888 return;
13889
13890 case OP_OTHERS:
13891 fputs_filtered ("others => ", stream);
13892 print_subexp (exp, pos, stream, PREC_SUFFIX);
13893 return;
13894
13895 case OP_CHOICES:
13896 for (i = 0; i < nargs-1; i += 1)
13897 {
13898 if (i > 0)
13899 fputs_filtered ("|", stream);
13900 print_subexp (exp, pos, stream, PREC_SUFFIX);
13901 }
13902 fputs_filtered (" => ", stream);
13903 print_subexp (exp, pos, stream, PREC_SUFFIX);
13904 return;
13905
13906 case OP_POSITIONAL:
13907 print_subexp (exp, pos, stream, PREC_SUFFIX);
13908 return;
13909
13910 case OP_AGGREGATE:
13911 fputs_filtered ("(", stream);
13912 for (i = 0; i < nargs; i += 1)
13913 {
13914 if (i > 0)
13915 fputs_filtered (", ", stream);
13916 print_subexp (exp, pos, stream, PREC_SUFFIX);
13917 }
13918 fputs_filtered (")", stream);
13919 return;
13920 }
13921 }
13922
13923 /* Table mapping opcodes into strings for printing operators
13924 and precedences of the operators. */
13925
13926 static const struct op_print ada_op_print_tab[] = {
13927 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13928 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13929 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13930 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13931 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13932 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13933 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13934 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13935 {"<=", BINOP_LEQ, PREC_ORDER, 0},
13936 {">=", BINOP_GEQ, PREC_ORDER, 0},
13937 {">", BINOP_GTR, PREC_ORDER, 0},
13938 {"<", BINOP_LESS, PREC_ORDER, 0},
13939 {">>", BINOP_RSH, PREC_SHIFT, 0},
13940 {"<<", BINOP_LSH, PREC_SHIFT, 0},
13941 {"+", BINOP_ADD, PREC_ADD, 0},
13942 {"-", BINOP_SUB, PREC_ADD, 0},
13943 {"&", BINOP_CONCAT, PREC_ADD, 0},
13944 {"*", BINOP_MUL, PREC_MUL, 0},
13945 {"/", BINOP_DIV, PREC_MUL, 0},
13946 {"rem", BINOP_REM, PREC_MUL, 0},
13947 {"mod", BINOP_MOD, PREC_MUL, 0},
13948 {"**", BINOP_EXP, PREC_REPEAT, 0},
13949 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13950 {"-", UNOP_NEG, PREC_PREFIX, 0},
13951 {"+", UNOP_PLUS, PREC_PREFIX, 0},
13952 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13953 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13954 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
13955 {".all", UNOP_IND, PREC_SUFFIX, 1},
13956 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13957 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
13958 {NULL, OP_NULL, PREC_SUFFIX, 0}
13959 };
13960 \f
13961 enum ada_primitive_types {
13962 ada_primitive_type_int,
13963 ada_primitive_type_long,
13964 ada_primitive_type_short,
13965 ada_primitive_type_char,
13966 ada_primitive_type_float,
13967 ada_primitive_type_double,
13968 ada_primitive_type_void,
13969 ada_primitive_type_long_long,
13970 ada_primitive_type_long_double,
13971 ada_primitive_type_natural,
13972 ada_primitive_type_positive,
13973 ada_primitive_type_system_address,
13974 ada_primitive_type_storage_offset,
13975 nr_ada_primitive_types
13976 };
13977
13978 static void
13979 ada_language_arch_info (struct gdbarch *gdbarch,
13980 struct language_arch_info *lai)
13981 {
13982 const struct builtin_type *builtin = builtin_type (gdbarch);
13983
13984 lai->primitive_type_vector
13985 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
13986 struct type *);
13987
13988 lai->primitive_type_vector [ada_primitive_type_int]
13989 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13990 0, "integer");
13991 lai->primitive_type_vector [ada_primitive_type_long]
13992 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13993 0, "long_integer");
13994 lai->primitive_type_vector [ada_primitive_type_short]
13995 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13996 0, "short_integer");
13997 lai->string_char_type
13998 = lai->primitive_type_vector [ada_primitive_type_char]
13999 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
14000 lai->primitive_type_vector [ada_primitive_type_float]
14001 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
14002 "float", gdbarch_float_format (gdbarch));
14003 lai->primitive_type_vector [ada_primitive_type_double]
14004 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
14005 "long_float", gdbarch_double_format (gdbarch));
14006 lai->primitive_type_vector [ada_primitive_type_long_long]
14007 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
14008 0, "long_long_integer");
14009 lai->primitive_type_vector [ada_primitive_type_long_double]
14010 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
14011 "long_long_float", gdbarch_long_double_format (gdbarch));
14012 lai->primitive_type_vector [ada_primitive_type_natural]
14013 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14014 0, "natural");
14015 lai->primitive_type_vector [ada_primitive_type_positive]
14016 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14017 0, "positive");
14018 lai->primitive_type_vector [ada_primitive_type_void]
14019 = builtin->builtin_void;
14020
14021 lai->primitive_type_vector [ada_primitive_type_system_address]
14022 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
14023 "void"));
14024 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
14025 = "system__address";
14026
14027 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14028 type. This is a signed integral type whose size is the same as
14029 the size of addresses. */
14030 {
14031 unsigned int addr_length = TYPE_LENGTH
14032 (lai->primitive_type_vector [ada_primitive_type_system_address]);
14033
14034 lai->primitive_type_vector [ada_primitive_type_storage_offset]
14035 = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
14036 "storage_offset");
14037 }
14038
14039 lai->bool_type_symbol = NULL;
14040 lai->bool_type_default = builtin->builtin_bool;
14041 }
14042 \f
14043 /* Language vector */
14044
14045 /* Not really used, but needed in the ada_language_defn. */
14046
14047 static void
14048 emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
14049 {
14050 ada_emit_char (c, type, stream, quoter, 1);
14051 }
14052
14053 static int
14054 parse (struct parser_state *ps)
14055 {
14056 warnings_issued = 0;
14057 return ada_parse (ps);
14058 }
14059
14060 static const struct exp_descriptor ada_exp_descriptor = {
14061 ada_print_subexp,
14062 ada_operator_length,
14063 ada_operator_check,
14064 ada_op_name,
14065 ada_dump_subexp_body,
14066 ada_evaluate_subexp
14067 };
14068
14069 /* symbol_name_matcher_ftype adapter for wild_match. */
14070
14071 static bool
14072 do_wild_match (const char *symbol_search_name,
14073 const lookup_name_info &lookup_name,
14074 completion_match_result *comp_match_res)
14075 {
14076 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
14077 }
14078
14079 /* symbol_name_matcher_ftype adapter for full_match. */
14080
14081 static bool
14082 do_full_match (const char *symbol_search_name,
14083 const lookup_name_info &lookup_name,
14084 completion_match_result *comp_match_res)
14085 {
14086 return full_match (symbol_search_name, ada_lookup_name (lookup_name));
14087 }
14088
14089 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
14090
14091 static bool
14092 do_exact_match (const char *symbol_search_name,
14093 const lookup_name_info &lookup_name,
14094 completion_match_result *comp_match_res)
14095 {
14096 return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
14097 }
14098
14099 /* Build the Ada lookup name for LOOKUP_NAME. */
14100
14101 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
14102 {
14103 const std::string &user_name = lookup_name.name ();
14104
14105 if (user_name[0] == '<')
14106 {
14107 if (user_name.back () == '>')
14108 m_encoded_name = user_name.substr (1, user_name.size () - 2);
14109 else
14110 m_encoded_name = user_name.substr (1, user_name.size () - 1);
14111 m_encoded_p = true;
14112 m_verbatim_p = true;
14113 m_wild_match_p = false;
14114 m_standard_p = false;
14115 }
14116 else
14117 {
14118 m_verbatim_p = false;
14119
14120 m_encoded_p = user_name.find ("__") != std::string::npos;
14121
14122 if (!m_encoded_p)
14123 {
14124 const char *folded = ada_fold_name (user_name.c_str ());
14125 const char *encoded = ada_encode_1 (folded, false);
14126 if (encoded != NULL)
14127 m_encoded_name = encoded;
14128 else
14129 m_encoded_name = user_name;
14130 }
14131 else
14132 m_encoded_name = user_name;
14133
14134 /* Handle the 'package Standard' special case. See description
14135 of m_standard_p. */
14136 if (startswith (m_encoded_name.c_str (), "standard__"))
14137 {
14138 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
14139 m_standard_p = true;
14140 }
14141 else
14142 m_standard_p = false;
14143
14144 /* If the name contains a ".", then the user is entering a fully
14145 qualified entity name, and the match must not be done in wild
14146 mode. Similarly, if the user wants to complete what looks
14147 like an encoded name, the match must not be done in wild
14148 mode. Also, in the standard__ special case always do
14149 non-wild matching. */
14150 m_wild_match_p
14151 = (lookup_name.match_type () != symbol_name_match_type::FULL
14152 && !m_encoded_p
14153 && !m_standard_p
14154 && user_name.find ('.') == std::string::npos);
14155 }
14156 }
14157
14158 /* symbol_name_matcher_ftype method for Ada. This only handles
14159 completion mode. */
14160
14161 static bool
14162 ada_symbol_name_matches (const char *symbol_search_name,
14163 const lookup_name_info &lookup_name,
14164 completion_match_result *comp_match_res)
14165 {
14166 return lookup_name.ada ().matches (symbol_search_name,
14167 lookup_name.match_type (),
14168 comp_match_res);
14169 }
14170
14171 /* A name matcher that matches the symbol name exactly, with
14172 strcmp. */
14173
14174 static bool
14175 literal_symbol_name_matcher (const char *symbol_search_name,
14176 const lookup_name_info &lookup_name,
14177 completion_match_result *comp_match_res)
14178 {
14179 const std::string &name = lookup_name.name ();
14180
14181 int cmp = (lookup_name.completion_mode ()
14182 ? strncmp (symbol_search_name, name.c_str (), name.size ())
14183 : strcmp (symbol_search_name, name.c_str ()));
14184 if (cmp == 0)
14185 {
14186 if (comp_match_res != NULL)
14187 comp_match_res->set_match (symbol_search_name);
14188 return true;
14189 }
14190 else
14191 return false;
14192 }
14193
14194 /* Implement the "la_get_symbol_name_matcher" language_defn method for
14195 Ada. */
14196
14197 static symbol_name_matcher_ftype *
14198 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
14199 {
14200 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
14201 return literal_symbol_name_matcher;
14202
14203 if (lookup_name.completion_mode ())
14204 return ada_symbol_name_matches;
14205 else
14206 {
14207 if (lookup_name.ada ().wild_match_p ())
14208 return do_wild_match;
14209 else if (lookup_name.ada ().verbatim_p ())
14210 return do_exact_match;
14211 else
14212 return do_full_match;
14213 }
14214 }
14215
14216 /* Implement the "la_read_var_value" language_defn method for Ada. */
14217
14218 static struct value *
14219 ada_read_var_value (struct symbol *var, const struct block *var_block,
14220 struct frame_info *frame)
14221 {
14222 /* The only case where default_read_var_value is not sufficient
14223 is when VAR is a renaming... */
14224 if (frame != nullptr)
14225 {
14226 const struct block *frame_block = get_frame_block (frame, NULL);
14227 if (frame_block != nullptr && ada_is_renaming_symbol (var))
14228 return ada_read_renaming_var_value (var, frame_block);
14229 }
14230
14231 /* This is a typical case where we expect the default_read_var_value
14232 function to work. */
14233 return default_read_var_value (var, var_block, frame);
14234 }
14235
14236 static const char *ada_extensions[] =
14237 {
14238 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14239 };
14240
14241 extern const struct language_defn ada_language_defn = {
14242 "ada", /* Language name */
14243 "Ada",
14244 language_ada,
14245 range_check_off,
14246 case_sensitive_on, /* Yes, Ada is case-insensitive, but
14247 that's not quite what this means. */
14248 array_row_major,
14249 macro_expansion_no,
14250 ada_extensions,
14251 &ada_exp_descriptor,
14252 parse,
14253 resolve,
14254 ada_printchar, /* Print a character constant */
14255 ada_printstr, /* Function to print string constant */
14256 emit_char, /* Function to print single char (not used) */
14257 ada_print_type, /* Print a type using appropriate syntax */
14258 ada_print_typedef, /* Print a typedef using appropriate syntax */
14259 ada_val_print, /* Print a value using appropriate syntax */
14260 ada_value_print, /* Print a top-level value */
14261 ada_read_var_value, /* la_read_var_value */
14262 NULL, /* Language specific skip_trampoline */
14263 NULL, /* name_of_this */
14264 true, /* la_store_sym_names_in_linkage_form_p */
14265 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
14266 basic_lookup_transparent_type, /* lookup_transparent_type */
14267 ada_la_decode, /* Language specific symbol demangler */
14268 ada_sniff_from_mangled_name,
14269 NULL, /* Language specific
14270 class_name_from_physname */
14271 ada_op_print_tab, /* expression operators for printing */
14272 0, /* c-style arrays */
14273 1, /* String lower bound */
14274 ada_get_gdb_completer_word_break_characters,
14275 ada_collect_symbol_completion_matches,
14276 ada_language_arch_info,
14277 ada_print_array_index,
14278 default_pass_by_reference,
14279 c_get_string,
14280 ada_watch_location_expression,
14281 ada_get_symbol_name_matcher, /* la_get_symbol_name_matcher */
14282 ada_iterate_over_symbols,
14283 default_search_name_hash,
14284 &ada_varobj_ops,
14285 NULL,
14286 NULL,
14287 ada_is_string_type,
14288 "(...)" /* la_struct_too_deep_ellipsis */
14289 };
14290
14291 /* Command-list for the "set/show ada" prefix command. */
14292 static struct cmd_list_element *set_ada_list;
14293 static struct cmd_list_element *show_ada_list;
14294
14295 /* Implement the "set ada" prefix command. */
14296
14297 static void
14298 set_ada_command (const char *arg, int from_tty)
14299 {
14300 printf_unfiltered (_(\
14301 "\"set ada\" must be followed by the name of a setting.\n"));
14302 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
14303 }
14304
14305 /* Implement the "show ada" prefix command. */
14306
14307 static void
14308 show_ada_command (const char *args, int from_tty)
14309 {
14310 cmd_show_list (show_ada_list, from_tty, "");
14311 }
14312
14313 static void
14314 initialize_ada_catchpoint_ops (void)
14315 {
14316 struct breakpoint_ops *ops;
14317
14318 initialize_breakpoint_ops ();
14319
14320 ops = &catch_exception_breakpoint_ops;
14321 *ops = bkpt_breakpoint_ops;
14322 ops->allocate_location = allocate_location_catch_exception;
14323 ops->re_set = re_set_catch_exception;
14324 ops->check_status = check_status_catch_exception;
14325 ops->print_it = print_it_catch_exception;
14326 ops->print_one = print_one_catch_exception;
14327 ops->print_mention = print_mention_catch_exception;
14328 ops->print_recreate = print_recreate_catch_exception;
14329
14330 ops = &catch_exception_unhandled_breakpoint_ops;
14331 *ops = bkpt_breakpoint_ops;
14332 ops->allocate_location = allocate_location_catch_exception_unhandled;
14333 ops->re_set = re_set_catch_exception_unhandled;
14334 ops->check_status = check_status_catch_exception_unhandled;
14335 ops->print_it = print_it_catch_exception_unhandled;
14336 ops->print_one = print_one_catch_exception_unhandled;
14337 ops->print_mention = print_mention_catch_exception_unhandled;
14338 ops->print_recreate = print_recreate_catch_exception_unhandled;
14339
14340 ops = &catch_assert_breakpoint_ops;
14341 *ops = bkpt_breakpoint_ops;
14342 ops->allocate_location = allocate_location_catch_assert;
14343 ops->re_set = re_set_catch_assert;
14344 ops->check_status = check_status_catch_assert;
14345 ops->print_it = print_it_catch_assert;
14346 ops->print_one = print_one_catch_assert;
14347 ops->print_mention = print_mention_catch_assert;
14348 ops->print_recreate = print_recreate_catch_assert;
14349
14350 ops = &catch_handlers_breakpoint_ops;
14351 *ops = bkpt_breakpoint_ops;
14352 ops->allocate_location = allocate_location_catch_handlers;
14353 ops->re_set = re_set_catch_handlers;
14354 ops->check_status = check_status_catch_handlers;
14355 ops->print_it = print_it_catch_handlers;
14356 ops->print_one = print_one_catch_handlers;
14357 ops->print_mention = print_mention_catch_handlers;
14358 ops->print_recreate = print_recreate_catch_handlers;
14359 }
14360
14361 /* This module's 'new_objfile' observer. */
14362
14363 static void
14364 ada_new_objfile_observer (struct objfile *objfile)
14365 {
14366 ada_clear_symbol_cache ();
14367 }
14368
14369 /* This module's 'free_objfile' observer. */
14370
14371 static void
14372 ada_free_objfile_observer (struct objfile *objfile)
14373 {
14374 ada_clear_symbol_cache ();
14375 }
14376
14377 void
14378 _initialize_ada_language (void)
14379 {
14380 initialize_ada_catchpoint_ops ();
14381
14382 add_prefix_cmd ("ada", no_class, set_ada_command,
14383 _("Prefix command for changing Ada-specific settings"),
14384 &set_ada_list, "set ada ", 0, &setlist);
14385
14386 add_prefix_cmd ("ada", no_class, show_ada_command,
14387 _("Generic command for showing Ada-specific settings."),
14388 &show_ada_list, "show ada ", 0, &showlist);
14389
14390 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14391 &trust_pad_over_xvs, _("\
14392 Enable or disable an optimization trusting PAD types over XVS types"), _("\
14393 Show whether an optimization trusting PAD types over XVS types is activated"),
14394 _("\
14395 This is related to the encoding used by the GNAT compiler. The debugger\n\
14396 should normally trust the contents of PAD types, but certain older versions\n\
14397 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14398 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14399 work around this bug. It is always safe to turn this option \"off\", but\n\
14400 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14401 this option to \"off\" unless necessary."),
14402 NULL, NULL, &set_ada_list, &show_ada_list);
14403
14404 add_setshow_boolean_cmd ("print-signatures", class_vars,
14405 &print_signatures, _("\
14406 Enable or disable the output of formal and return types for functions in the \
14407 overloads selection menu"), _("\
14408 Show whether the output of formal and return types for functions in the \
14409 overloads selection menu is activated"),
14410 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14411
14412 add_catch_command ("exception", _("\
14413 Catch Ada exceptions, when raised.\n\
14414 Usage: catch exception [ARG] [if CONDITION]\n\
14415 Without any argument, stop when any Ada exception is raised.\n\
14416 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14417 being raised does not have a handler (and will therefore lead to the task's\n\
14418 termination).\n\
14419 Otherwise, the catchpoint only stops when the name of the exception being\n\
14420 raised is the same as ARG.\n\
14421 CONDITION is a boolean expression that is evaluated to see whether the\n\
14422 exception should cause a stop."),
14423 catch_ada_exception_command,
14424 catch_ada_completer,
14425 CATCH_PERMANENT,
14426 CATCH_TEMPORARY);
14427
14428 add_catch_command ("handlers", _("\
14429 Catch Ada exceptions, when handled.\n\
14430 Usage: catch handlers [ARG] [if CONDITION]\n\
14431 Without any argument, stop when any Ada exception is handled.\n\
14432 With an argument, catch only exceptions with the given name.\n\
14433 CONDITION is a boolean expression that is evaluated to see whether the\n\
14434 exception should cause a stop."),
14435 catch_ada_handlers_command,
14436 catch_ada_completer,
14437 CATCH_PERMANENT,
14438 CATCH_TEMPORARY);
14439 add_catch_command ("assert", _("\
14440 Catch failed Ada assertions, when raised.\n\
14441 Usage: catch assert [if CONDITION]\n\
14442 CONDITION is a boolean expression that is evaluated to see whether the\n\
14443 exception should cause a stop."),
14444 catch_assert_command,
14445 NULL,
14446 CATCH_PERMANENT,
14447 CATCH_TEMPORARY);
14448
14449 varsize_limit = 65536;
14450 add_setshow_uinteger_cmd ("varsize-limit", class_support,
14451 &varsize_limit, _("\
14452 Set the maximum number of bytes allowed in a variable-size object."), _("\
14453 Show the maximum number of bytes allowed in a variable-size object."), _("\
14454 Attempts to access an object whose size is not a compile-time constant\n\
14455 and exceeds this limit will cause an error."),
14456 NULL, NULL, &setlist, &showlist);
14457
14458 add_info ("exceptions", info_exceptions_command,
14459 _("\
14460 List all Ada exception names.\n\
14461 Usage: info exceptions [REGEXP]\n\
14462 If a regular expression is passed as an argument, only those matching\n\
14463 the regular expression are listed."));
14464
14465 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14466 _("Set Ada maintenance-related variables."),
14467 &maint_set_ada_cmdlist, "maintenance set ada ",
14468 0/*allow-unknown*/, &maintenance_set_cmdlist);
14469
14470 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14471 _("Show Ada maintenance-related variables"),
14472 &maint_show_ada_cmdlist, "maintenance show ada ",
14473 0/*allow-unknown*/, &maintenance_show_cmdlist);
14474
14475 add_setshow_boolean_cmd
14476 ("ignore-descriptive-types", class_maintenance,
14477 &ada_ignore_descriptive_types_p,
14478 _("Set whether descriptive types generated by GNAT should be ignored."),
14479 _("Show whether descriptive types generated by GNAT should be ignored."),
14480 _("\
14481 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14482 DWARF attribute."),
14483 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14484
14485 decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
14486 NULL, xcalloc, xfree);
14487
14488 /* The ada-lang observers. */
14489 gdb::observers::new_objfile.attach (ada_new_objfile_observer);
14490 gdb::observers::free_objfile.attach (ada_free_objfile_observer);
14491 gdb::observers::inferior_exit.attach (ada_inferior_exit);
14492 }