]> Git Repo - binutils.git/blob - gdb/ada-lang.c
gdb: remove TYPE_LENGTH
[binutils.git] / gdb / ada-lang.c
1 /* Ada language support routines for GDB, the GNU debugger.
2
3    Copyright (C) 1992-2022 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 "gdbsupport/gdb_regex.h"
24 #include "frame.h"
25 #include "symtab.h"
26 #include "gdbtypes.h"
27 #include "gdbcmd.h"
28 #include "expression.h"
29 #include "parser-defs.h"
30 #include "language.h"
31 #include "varobj.h"
32 #include "inferior.h"
33 #include "symfile.h"
34 #include "objfiles.h"
35 #include "breakpoint.h"
36 #include "gdbcore.h"
37 #include "hashtab.h"
38 #include "gdbsupport/gdb_obstack.h"
39 #include "ada-lang.h"
40 #include "completer.h"
41 #include "ui-out.h"
42 #include "block.h"
43 #include "infcall.h"
44 #include "annotate.h"
45 #include "valprint.h"
46 #include "source.h"
47 #include "observable.h"
48 #include "stack.h"
49 #include "typeprint.h"
50 #include "namespace.h"
51 #include "cli/cli-style.h"
52 #include "cli/cli-decode.h"
53
54 #include "value.h"
55 #include "mi/mi-common.h"
56 #include "arch-utils.h"
57 #include "cli/cli-utils.h"
58 #include "gdbsupport/function-view.h"
59 #include "gdbsupport/byte-vector.h"
60 #include <algorithm>
61 #include "ada-exp.h"
62 #include "charset.h"
63
64 /* Define whether or not the C operator '/' truncates towards zero for
65    differently signed operands (truncation direction is undefined in C).
66    Copied from valarith.c.  */
67
68 #ifndef TRUNCATION_TOWARDS_ZERO
69 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
70 #endif
71
72 static struct type *desc_base_type (struct type *);
73
74 static struct type *desc_bounds_type (struct type *);
75
76 static struct value *desc_bounds (struct value *);
77
78 static int fat_pntr_bounds_bitpos (struct type *);
79
80 static int fat_pntr_bounds_bitsize (struct type *);
81
82 static struct type *desc_data_target_type (struct type *);
83
84 static struct value *desc_data (struct value *);
85
86 static int fat_pntr_data_bitpos (struct type *);
87
88 static int fat_pntr_data_bitsize (struct type *);
89
90 static struct value *desc_one_bound (struct value *, int, int);
91
92 static int desc_bound_bitpos (struct type *, int, int);
93
94 static int desc_bound_bitsize (struct type *, int, int);
95
96 static struct type *desc_index_type (struct type *, int);
97
98 static int desc_arity (struct type *);
99
100 static int ada_args_match (struct symbol *, struct value **, int);
101
102 static struct value *make_array_descriptor (struct type *, struct value *);
103
104 static void ada_add_block_symbols (std::vector<struct block_symbol> &,
105                                    const struct block *,
106                                    const lookup_name_info &lookup_name,
107                                    domain_enum, struct objfile *);
108
109 static void ada_add_all_symbols (std::vector<struct block_symbol> &,
110                                  const struct block *,
111                                  const lookup_name_info &lookup_name,
112                                  domain_enum, int, int *);
113
114 static int is_nonfunction (const std::vector<struct block_symbol> &);
115
116 static void add_defn_to_vec (std::vector<struct block_symbol> &,
117                              struct symbol *,
118                              const struct block *);
119
120 static int possible_user_operator_p (enum exp_opcode, struct value **);
121
122 static const char *ada_decoded_op_name (enum exp_opcode);
123
124 static int numeric_type_p (struct type *);
125
126 static int integer_type_p (struct type *);
127
128 static int scalar_type_p (struct type *);
129
130 static int discrete_type_p (struct type *);
131
132 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
133                                                 int, int);
134
135 static struct type *ada_find_parallel_type_with_name (struct type *,
136                                                       const char *);
137
138 static int is_dynamic_field (struct type *, int);
139
140 static struct type *to_fixed_variant_branch_type (struct type *,
141                                                   const gdb_byte *,
142                                                   CORE_ADDR, struct value *);
143
144 static struct type *to_fixed_array_type (struct type *, struct value *, int);
145
146 static struct type *to_fixed_range_type (struct type *, struct value *);
147
148 static struct type *to_static_fixed_type (struct type *);
149 static struct type *static_unwrap_type (struct type *type);
150
151 static struct value *unwrap_value (struct value *);
152
153 static struct type *constrained_packed_array_type (struct type *, long *);
154
155 static struct type *decode_constrained_packed_array_type (struct type *);
156
157 static long decode_packed_array_bitsize (struct type *);
158
159 static struct value *decode_constrained_packed_array (struct value *);
160
161 static int ada_is_unconstrained_packed_array_type (struct type *);
162
163 static struct value *value_subscript_packed (struct value *, int,
164                                              struct value **);
165
166 static struct value *coerce_unspec_val_to_type (struct value *,
167                                                 struct type *);
168
169 static int lesseq_defined_than (struct symbol *, struct symbol *);
170
171 static int equiv_types (struct type *, struct type *);
172
173 static int is_name_suffix (const char *);
174
175 static int advance_wild_match (const char **, const char *, char);
176
177 static bool wild_match (const char *name, const char *patn);
178
179 static struct value *ada_coerce_ref (struct value *);
180
181 static LONGEST pos_atr (struct value *);
182
183 static struct value *val_atr (struct type *, LONGEST);
184
185 static struct symbol *standard_lookup (const char *, const struct block *,
186                                        domain_enum);
187
188 static struct value *ada_search_struct_field (const char *, struct value *, int,
189                                               struct type *);
190
191 static int find_struct_field (const char *, struct type *, int,
192                               struct type **, int *, int *, int *, int *);
193
194 static int ada_resolve_function (std::vector<struct block_symbol> &,
195                                  struct value **, int, const char *,
196                                  struct type *, bool);
197
198 static int ada_is_direct_array_type (struct type *);
199
200 static struct value *ada_index_struct_field (int, struct value *, int,
201                                              struct type *);
202
203 static void add_component_interval (LONGEST, LONGEST, std::vector<LONGEST> &);
204
205
206 static struct type *ada_find_any_type (const char *name);
207
208 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
209   (const lookup_name_info &lookup_name);
210
211 \f
212
213 /* The character set used for source files.  */
214 static const char *ada_source_charset;
215
216 /* The string "UTF-8".  This is here so we can check for the UTF-8
217    charset using == rather than strcmp.  */
218 static const char ada_utf8[] = "UTF-8";
219
220 /* Each entry in the UTF-32 case-folding table is of this form.  */
221 struct utf8_entry
222 {
223   /* The start and end, inclusive, of this range of codepoints.  */
224   uint32_t start, end;
225   /* The delta to apply to get the upper-case form.  0 if this is
226      already upper-case.  */
227   int upper_delta;
228   /* The delta to apply to get the lower-case form.  0 if this is
229      already lower-case.  */
230   int lower_delta;
231
232   bool operator< (uint32_t val) const
233   {
234     return end < val;
235   }
236 };
237
238 static const utf8_entry ada_case_fold[] =
239 {
240 #include "ada-casefold.h"
241 };
242
243 \f
244
245 /* The result of a symbol lookup to be stored in our symbol cache.  */
246
247 struct cache_entry
248 {
249   /* The name used to perform the lookup.  */
250   const char *name;
251   /* The namespace used during the lookup.  */
252   domain_enum domain;
253   /* The symbol returned by the lookup, or NULL if no matching symbol
254      was found.  */
255   struct symbol *sym;
256   /* The block where the symbol was found, or NULL if no matching
257      symbol was found.  */
258   const struct block *block;
259   /* A pointer to the next entry with the same hash.  */
260   struct cache_entry *next;
261 };
262
263 /* The Ada symbol cache, used to store the result of Ada-mode symbol
264    lookups in the course of executing the user's commands.
265
266    The cache is implemented using a simple, fixed-sized hash.
267    The size is fixed on the grounds that there are not likely to be
268    all that many symbols looked up during any given session, regardless
269    of the size of the symbol table.  If we decide to go to a resizable
270    table, let's just use the stuff from libiberty instead.  */
271
272 #define HASH_SIZE 1009
273
274 struct ada_symbol_cache
275 {
276   /* An obstack used to store the entries in our cache.  */
277   struct auto_obstack cache_space;
278
279   /* The root of the hash table used to implement our symbol cache.  */
280   struct cache_entry *root[HASH_SIZE] {};
281 };
282
283 static const char ada_completer_word_break_characters[] =
284 #ifdef VMS
285   " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
286 #else
287   " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
288 #endif
289
290 /* The name of the symbol to use to get the name of the main subprogram.  */
291 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
292   = "__gnat_ada_main_program_name";
293
294 /* Limit on the number of warnings to raise per expression evaluation.  */
295 static int warning_limit = 2;
296
297 /* Number of warning messages issued; reset to 0 by cleanups after
298    expression evaluation.  */
299 static int warnings_issued = 0;
300
301 static const char * const known_runtime_file_name_patterns[] = {
302   ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
303 };
304
305 static const char * const known_auxiliary_function_name_patterns[] = {
306   ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
307 };
308
309 /* Maintenance-related settings for this module.  */
310
311 static struct cmd_list_element *maint_set_ada_cmdlist;
312 static struct cmd_list_element *maint_show_ada_cmdlist;
313
314 /* The "maintenance ada set/show ignore-descriptive-type" value.  */
315
316 static bool ada_ignore_descriptive_types_p = false;
317
318                         /* Inferior-specific data.  */
319
320 /* Per-inferior data for this module.  */
321
322 struct ada_inferior_data
323 {
324   /* The ada__tags__type_specific_data type, which is used when decoding
325      tagged types.  With older versions of GNAT, this type was directly
326      accessible through a component ("tsd") in the object tag.  But this
327      is no longer the case, so we cache it for each inferior.  */
328   struct type *tsd_type = nullptr;
329
330   /* The exception_support_info data.  This data is used to determine
331      how to implement support for Ada exception catchpoints in a given
332      inferior.  */
333   const struct exception_support_info *exception_info = nullptr;
334 };
335
336 /* Our key to this module's inferior data.  */
337 static const registry<inferior>::key<ada_inferior_data> ada_inferior_data;
338
339 /* Return our inferior data for the given inferior (INF).
340
341    This function always returns a valid pointer to an allocated
342    ada_inferior_data structure.  If INF's inferior data has not
343    been previously set, this functions creates a new one with all
344    fields set to zero, sets INF's inferior to it, and then returns
345    a pointer to that newly allocated ada_inferior_data.  */
346
347 static struct ada_inferior_data *
348 get_ada_inferior_data (struct inferior *inf)
349 {
350   struct ada_inferior_data *data;
351
352   data = ada_inferior_data.get (inf);
353   if (data == NULL)
354     data = ada_inferior_data.emplace (inf);
355
356   return data;
357 }
358
359 /* Perform all necessary cleanups regarding our module's inferior data
360    that is required after the inferior INF just exited.  */
361
362 static void
363 ada_inferior_exit (struct inferior *inf)
364 {
365   ada_inferior_data.clear (inf);
366 }
367
368
369                         /* program-space-specific data.  */
370
371 /* This module's per-program-space data.  */
372 struct ada_pspace_data
373 {
374   /* The Ada symbol cache.  */
375   std::unique_ptr<ada_symbol_cache> sym_cache;
376 };
377
378 /* Key to our per-program-space data.  */
379 static const registry<program_space>::key<ada_pspace_data>
380   ada_pspace_data_handle;
381
382 /* Return this module's data for the given program space (PSPACE).
383    If not is found, add a zero'ed one now.
384
385    This function always returns a valid object.  */
386
387 static struct ada_pspace_data *
388 get_ada_pspace_data (struct program_space *pspace)
389 {
390   struct ada_pspace_data *data;
391
392   data = ada_pspace_data_handle.get (pspace);
393   if (data == NULL)
394     data = ada_pspace_data_handle.emplace (pspace);
395
396   return data;
397 }
398
399                         /* Utilities */
400
401 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
402    all typedef layers have been peeled.  Otherwise, return TYPE.
403
404    Normally, we really expect a typedef type to only have 1 typedef layer.
405    In other words, we really expect the target type of a typedef type to be
406    a non-typedef type.  This is particularly true for Ada units, because
407    the language does not have a typedef vs not-typedef distinction.
408    In that respect, the Ada compiler has been trying to eliminate as many
409    typedef definitions in the debugging information, since they generally
410    do not bring any extra information (we still use typedef under certain
411    circumstances related mostly to the GNAT encoding).
412
413    Unfortunately, we have seen situations where the debugging information
414    generated by the compiler leads to such multiple typedef layers.  For
415    instance, consider the following example with stabs:
416
417      .stabs  "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
418      .stabs  "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
419
420    This is an error in the debugging information which causes type
421    pck__float_array___XUP to be defined twice, and the second time,
422    it is defined as a typedef of a typedef.
423
424    This is on the fringe of legality as far as debugging information is
425    concerned, and certainly unexpected.  But it is easy to handle these
426    situations correctly, so we can afford to be lenient in this case.  */
427
428 static struct type *
429 ada_typedef_target_type (struct type *type)
430 {
431   while (type->code () == TYPE_CODE_TYPEDEF)
432     type = type->target_type ();
433   return type;
434 }
435
436 /* Given DECODED_NAME a string holding a symbol name in its
437    decoded form (ie using the Ada dotted notation), returns
438    its unqualified name.  */
439
440 static const char *
441 ada_unqualified_name (const char *decoded_name)
442 {
443   const char *result;
444   
445   /* If the decoded name starts with '<', it means that the encoded
446      name does not follow standard naming conventions, and thus that
447      it is not your typical Ada symbol name.  Trying to unqualify it
448      is therefore pointless and possibly erroneous.  */
449   if (decoded_name[0] == '<')
450     return decoded_name;
451
452   result = strrchr (decoded_name, '.');
453   if (result != NULL)
454     result++;                   /* Skip the dot...  */
455   else
456     result = decoded_name;
457
458   return result;
459 }
460
461 /* Return a string starting with '<', followed by STR, and '>'.  */
462
463 static std::string
464 add_angle_brackets (const char *str)
465 {
466   return string_printf ("<%s>", str);
467 }
468
469 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
470    suffix of FIELD_NAME beginning "___".  */
471
472 static int
473 field_name_match (const char *field_name, const char *target)
474 {
475   int len = strlen (target);
476
477   return
478     (strncmp (field_name, target, len) == 0
479      && (field_name[len] == '\0'
480          || (startswith (field_name + len, "___")
481              && strcmp (field_name + strlen (field_name) - 6,
482                         "___XVN") != 0)));
483 }
484
485
486 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
487    a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
488    and return its index.  This function also handles fields whose name
489    have ___ suffixes because the compiler sometimes alters their name
490    by adding such a suffix to represent fields with certain constraints.
491    If the field could not be found, return a negative number if
492    MAYBE_MISSING is set.  Otherwise raise an error.  */
493
494 int
495 ada_get_field_index (const struct type *type, const char *field_name,
496                      int maybe_missing)
497 {
498   int fieldno;
499   struct type *struct_type = check_typedef ((struct type *) type);
500
501   for (fieldno = 0; fieldno < struct_type->num_fields (); fieldno++)
502     if (field_name_match (struct_type->field (fieldno).name (), field_name))
503       return fieldno;
504
505   if (!maybe_missing)
506     error (_("Unable to find field %s in struct %s.  Aborting"),
507            field_name, struct_type->name ());
508
509   return -1;
510 }
511
512 /* The length of the prefix of NAME prior to any "___" suffix.  */
513
514 int
515 ada_name_prefix_len (const char *name)
516 {
517   if (name == NULL)
518     return 0;
519   else
520     {
521       const char *p = strstr (name, "___");
522
523       if (p == NULL)
524         return strlen (name);
525       else
526         return p - name;
527     }
528 }
529
530 /* Return non-zero if SUFFIX is a suffix of STR.
531    Return zero if STR is null.  */
532
533 static int
534 is_suffix (const char *str, const char *suffix)
535 {
536   int len1, len2;
537
538   if (str == NULL)
539     return 0;
540   len1 = strlen (str);
541   len2 = strlen (suffix);
542   return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
543 }
544
545 /* The contents of value VAL, treated as a value of type TYPE.  The
546    result is an lval in memory if VAL is.  */
547
548 static struct value *
549 coerce_unspec_val_to_type (struct value *val, struct type *type)
550 {
551   type = ada_check_typedef (type);
552   if (value_type (val) == type)
553     return val;
554   else
555     {
556       struct value *result;
557
558       if (value_optimized_out (val))
559         result = allocate_optimized_out_value (type);
560       else if (value_lazy (val)
561                /* Be careful not to make a lazy not_lval value.  */
562                || (VALUE_LVAL (val) != not_lval
563                    && type->length () > value_type (val)->length ()))
564         result = allocate_value_lazy (type);
565       else
566         {
567           result = allocate_value (type);
568           value_contents_copy (result, 0, val, 0, type->length ());
569         }
570       set_value_component_location (result, val);
571       set_value_bitsize (result, value_bitsize (val));
572       set_value_bitpos (result, value_bitpos (val));
573       if (VALUE_LVAL (result) == lval_memory)
574         set_value_address (result, value_address (val));
575       return result;
576     }
577 }
578
579 static const gdb_byte *
580 cond_offset_host (const gdb_byte *valaddr, long offset)
581 {
582   if (valaddr == NULL)
583     return NULL;
584   else
585     return valaddr + offset;
586 }
587
588 static CORE_ADDR
589 cond_offset_target (CORE_ADDR address, long offset)
590 {
591   if (address == 0)
592     return 0;
593   else
594     return address + offset;
595 }
596
597 /* Issue a warning (as for the definition of warning in utils.c, but
598    with exactly one argument rather than ...), unless the limit on the
599    number of warnings has passed during the evaluation of the current
600    expression.  */
601
602 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
603    provided by "complaint".  */
604 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
605
606 static void
607 lim_warning (const char *format, ...)
608 {
609   va_list args;
610
611   va_start (args, format);
612   warnings_issued += 1;
613   if (warnings_issued <= warning_limit)
614     vwarning (format, args);
615
616   va_end (args);
617 }
618
619 /* Maximum value of a SIZE-byte signed integer type.  */
620 static LONGEST
621 max_of_size (int size)
622 {
623   LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
624
625   return top_bit | (top_bit - 1);
626 }
627
628 /* Minimum value of a SIZE-byte signed integer type.  */
629 static LONGEST
630 min_of_size (int size)
631 {
632   return -max_of_size (size) - 1;
633 }
634
635 /* Maximum value of a SIZE-byte unsigned integer type.  */
636 static ULONGEST
637 umax_of_size (int size)
638 {
639   ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
640
641   return top_bit | (top_bit - 1);
642 }
643
644 /* Maximum value of integral type T, as a signed quantity.  */
645 static LONGEST
646 max_of_type (struct type *t)
647 {
648   if (t->is_unsigned ())
649     return (LONGEST) umax_of_size (t->length ());
650   else
651     return max_of_size (t->length ());
652 }
653
654 /* Minimum value of integral type T, as a signed quantity.  */
655 static LONGEST
656 min_of_type (struct type *t)
657 {
658   if (t->is_unsigned ())
659     return 0;
660   else
661     return min_of_size (t->length ());
662 }
663
664 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
665 LONGEST
666 ada_discrete_type_high_bound (struct type *type)
667 {
668   type = resolve_dynamic_type (type, {}, 0);
669   switch (type->code ())
670     {
671     case TYPE_CODE_RANGE:
672       {
673         const dynamic_prop &high = type->bounds ()->high;
674
675         if (high.kind () == PROP_CONST)
676           return high.const_val ();
677         else
678           {
679             gdb_assert (high.kind () == PROP_UNDEFINED);
680
681             /* This happens when trying to evaluate a type's dynamic bound
682                without a live target.  There is nothing relevant for us to
683                return here, so return 0.  */
684             return 0;
685           }
686       }
687     case TYPE_CODE_ENUM:
688       return type->field (type->num_fields () - 1).loc_enumval ();
689     case TYPE_CODE_BOOL:
690       return 1;
691     case TYPE_CODE_CHAR:
692     case TYPE_CODE_INT:
693       return max_of_type (type);
694     default:
695       error (_("Unexpected type in ada_discrete_type_high_bound."));
696     }
697 }
698
699 /* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
700 LONGEST
701 ada_discrete_type_low_bound (struct type *type)
702 {
703   type = resolve_dynamic_type (type, {}, 0);
704   switch (type->code ())
705     {
706     case TYPE_CODE_RANGE:
707       {
708         const dynamic_prop &low = type->bounds ()->low;
709
710         if (low.kind () == PROP_CONST)
711           return low.const_val ();
712         else
713           {
714             gdb_assert (low.kind () == PROP_UNDEFINED);
715
716             /* This happens when trying to evaluate a type's dynamic bound
717                without a live target.  There is nothing relevant for us to
718                return here, so return 0.  */
719             return 0;
720           }
721       }
722     case TYPE_CODE_ENUM:
723       return type->field (0).loc_enumval ();
724     case TYPE_CODE_BOOL:
725       return 0;
726     case TYPE_CODE_CHAR:
727     case TYPE_CODE_INT:
728       return min_of_type (type);
729     default:
730       error (_("Unexpected type in ada_discrete_type_low_bound."));
731     }
732 }
733
734 /* The identity on non-range types.  For range types, the underlying
735    non-range scalar type.  */
736
737 static struct type *
738 get_base_type (struct type *type)
739 {
740   while (type != NULL && type->code () == TYPE_CODE_RANGE)
741     {
742       if (type == type->target_type () || type->target_type () == NULL)
743         return type;
744       type = type->target_type ();
745     }
746   return type;
747 }
748
749 /* Return a decoded version of the given VALUE.  This means returning
750    a value whose type is obtained by applying all the GNAT-specific
751    encodings, making the resulting type a static but standard description
752    of the initial type.  */
753
754 struct value *
755 ada_get_decoded_value (struct value *value)
756 {
757   struct type *type = ada_check_typedef (value_type (value));
758
759   if (ada_is_array_descriptor_type (type)
760       || (ada_is_constrained_packed_array_type (type)
761           && type->code () != TYPE_CODE_PTR))
762     {
763       if (type->code () == TYPE_CODE_TYPEDEF)  /* array access type.  */
764         value = ada_coerce_to_simple_array_ptr (value);
765       else
766         value = ada_coerce_to_simple_array (value);
767     }
768   else
769     value = ada_to_fixed_value (value);
770
771   return value;
772 }
773
774 /* Same as ada_get_decoded_value, but with the given TYPE.
775    Because there is no associated actual value for this type,
776    the resulting type might be a best-effort approximation in
777    the case of dynamic types.  */
778
779 struct type *
780 ada_get_decoded_type (struct type *type)
781 {
782   type = to_static_fixed_type (type);
783   if (ada_is_constrained_packed_array_type (type))
784     type = ada_coerce_to_simple_array_type (type);
785   return type;
786 }
787
788 \f
789
790                                 /* Language Selection */
791
792 /* If the main program is in Ada, return language_ada, otherwise return LANG
793    (the main program is in Ada iif the adainit symbol is found).  */
794
795 static enum language
796 ada_update_initial_language (enum language lang)
797 {
798   if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
799     return language_ada;
800
801   return lang;
802 }
803
804 /* If the main procedure is written in Ada, then return its name.
805    The result is good until the next call.  Return NULL if the main
806    procedure doesn't appear to be in Ada.  */
807
808 char *
809 ada_main_name (void)
810 {
811   struct bound_minimal_symbol msym;
812   static gdb::unique_xmalloc_ptr<char> main_program_name;
813
814   /* For Ada, the name of the main procedure is stored in a specific
815      string constant, generated by the binder.  Look for that symbol,
816      extract its address, and then read that string.  If we didn't find
817      that string, then most probably the main procedure is not written
818      in Ada.  */
819   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
820
821   if (msym.minsym != NULL)
822     {
823       CORE_ADDR main_program_name_addr = msym.value_address ();
824       if (main_program_name_addr == 0)
825         error (_("Invalid address for Ada main program name."));
826
827       main_program_name = target_read_string (main_program_name_addr, 1024);
828       return main_program_name.get ();
829     }
830
831   /* The main procedure doesn't seem to be in Ada.  */
832   return NULL;
833 }
834 \f
835                                 /* Symbols */
836
837 /* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
838    of NULLs.  */
839
840 const struct ada_opname_map ada_opname_table[] = {
841   {"Oadd", "\"+\"", BINOP_ADD},
842   {"Osubtract", "\"-\"", BINOP_SUB},
843   {"Omultiply", "\"*\"", BINOP_MUL},
844   {"Odivide", "\"/\"", BINOP_DIV},
845   {"Omod", "\"mod\"", BINOP_MOD},
846   {"Orem", "\"rem\"", BINOP_REM},
847   {"Oexpon", "\"**\"", BINOP_EXP},
848   {"Olt", "\"<\"", BINOP_LESS},
849   {"Ole", "\"<=\"", BINOP_LEQ},
850   {"Ogt", "\">\"", BINOP_GTR},
851   {"Oge", "\">=\"", BINOP_GEQ},
852   {"Oeq", "\"=\"", BINOP_EQUAL},
853   {"One", "\"/=\"", BINOP_NOTEQUAL},
854   {"Oand", "\"and\"", BINOP_BITWISE_AND},
855   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
856   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
857   {"Oconcat", "\"&\"", BINOP_CONCAT},
858   {"Oabs", "\"abs\"", UNOP_ABS},
859   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
860   {"Oadd", "\"+\"", UNOP_PLUS},
861   {"Osubtract", "\"-\"", UNOP_NEG},
862   {NULL, NULL}
863 };
864
865 /* If STR is a decoded version of a compiler-provided suffix (like the
866    "[cold]" in "symbol[cold]"), return true.  Otherwise, return
867    false.  */
868
869 static bool
870 is_compiler_suffix (const char *str)
871 {
872   gdb_assert (*str == '[');
873   ++str;
874   while (*str != '\0' && isalpha (*str))
875     ++str;
876   /* We accept a missing "]" in order to support completion.  */
877   return *str == '\0' || (str[0] == ']' && str[1] == '\0');
878 }
879
880 /* Append a non-ASCII character to RESULT.  */
881 static void
882 append_hex_encoded (std::string &result, uint32_t one_char)
883 {
884   if (one_char <= 0xff)
885     {
886       result.append ("U");
887       result.append (phex (one_char, 1));
888     }
889   else if (one_char <= 0xffff)
890     {
891       result.append ("W");
892       result.append (phex (one_char, 2));
893     }
894   else
895     {
896       result.append ("WW");
897       result.append (phex (one_char, 4));
898     }
899 }
900
901 /* Return a string that is a copy of the data in STORAGE, with
902    non-ASCII characters replaced by the appropriate hex encoding.  A
903    template is used because, for UTF-8, we actually want to work with
904    UTF-32 codepoints.  */
905 template<typename T>
906 std::string
907 copy_and_hex_encode (struct obstack *storage)
908 {
909   const T *chars = (T *) obstack_base (storage);
910   int num_chars = obstack_object_size (storage) / sizeof (T);
911   std::string result;
912   for (int i = 0; i < num_chars; ++i)
913     {
914       if (chars[i] <= 0x7f)
915         {
916           /* The host character set has to be a superset of ASCII, as
917              are all the other character sets we can use.  */
918           result.push_back (chars[i]);
919         }
920       else
921         append_hex_encoded (result, chars[i]);
922     }
923   return result;
924 }
925
926 /* The "encoded" form of DECODED, according to GNAT conventions.  If
927    THROW_ERRORS, throw an error if invalid operator name is found.
928    Otherwise, return the empty string in that case.  */
929
930 static std::string
931 ada_encode_1 (const char *decoded, bool throw_errors)
932 {
933   if (decoded == NULL)
934     return {};
935
936   std::string encoding_buffer;
937   bool saw_non_ascii = false;
938   for (const char *p = decoded; *p != '\0'; p += 1)
939     {
940       if ((*p & 0x80) != 0)
941         saw_non_ascii = true;
942
943       if (*p == '.')
944         encoding_buffer.append ("__");
945       else if (*p == '[' && is_compiler_suffix (p))
946         {
947           encoding_buffer = encoding_buffer + "." + (p + 1);
948           if (encoding_buffer.back () == ']')
949             encoding_buffer.pop_back ();
950           break;
951         }
952       else if (*p == '"')
953         {
954           const struct ada_opname_map *mapping;
955
956           for (mapping = ada_opname_table;
957                mapping->encoded != NULL
958                && !startswith (p, mapping->decoded); mapping += 1)
959             ;
960           if (mapping->encoded == NULL)
961             {
962               if (throw_errors)
963                 error (_("invalid Ada operator name: %s"), p);
964               else
965                 return {};
966             }
967           encoding_buffer.append (mapping->encoded);
968           break;
969         }
970       else
971         encoding_buffer.push_back (*p);
972     }
973
974   /* If a non-ASCII character is seen, we must convert it to the
975      appropriate hex form.  As this is more expensive, we keep track
976      of whether it is even necessary.  */
977   if (saw_non_ascii)
978     {
979       auto_obstack storage;
980       bool is_utf8 = ada_source_charset == ada_utf8;
981       try
982         {
983           convert_between_encodings
984             (host_charset (),
985              is_utf8 ? HOST_UTF32 : ada_source_charset,
986              (const gdb_byte *) encoding_buffer.c_str (),
987              encoding_buffer.length (), 1,
988              &storage, translit_none);
989         }
990       catch (const gdb_exception &)
991         {
992           static bool warned = false;
993
994           /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
995              might like to know why.  */
996           if (!warned)
997             {
998               warned = true;
999               warning (_("charset conversion failure for '%s'.\n"
1000                          "You may have the wrong value for 'set ada source-charset'."),
1001                        encoding_buffer.c_str ());
1002             }
1003
1004           /* We don't try to recover from errors.  */
1005           return encoding_buffer;
1006         }
1007
1008       if (is_utf8)
1009         return copy_and_hex_encode<uint32_t> (&storage);
1010       return copy_and_hex_encode<gdb_byte> (&storage);
1011     }
1012
1013   return encoding_buffer;
1014 }
1015
1016 /* Find the entry for C in the case-folding table.  Return nullptr if
1017    the entry does not cover C.  */
1018 static const utf8_entry *
1019 find_case_fold_entry (uint32_t c)
1020 {
1021   auto iter = std::lower_bound (std::begin (ada_case_fold),
1022                                 std::end (ada_case_fold),
1023                                 c);
1024   if (iter == std::end (ada_case_fold)
1025       || c < iter->start
1026       || c > iter->end)
1027     return nullptr;
1028   return &*iter;
1029 }
1030
1031 /* Return NAME folded to lower case, or, if surrounded by single
1032    quotes, unfolded, but with the quotes stripped away.  If
1033    THROW_ON_ERROR is true, encoding failures will throw an exception
1034    rather than emitting a warning.  Result good to next call.  */
1035
1036 static const char *
1037 ada_fold_name (gdb::string_view name, bool throw_on_error = false)
1038 {
1039   static std::string fold_storage;
1040
1041   if (!name.empty () && name[0] == '\'')
1042     fold_storage = gdb::to_string (name.substr (1, name.size () - 2));
1043   else
1044     {
1045       /* Why convert to UTF-32 and implement our own case-folding,
1046          rather than convert to wchar_t and use the platform's
1047          functions?  I'm glad you asked.
1048
1049          The main problem is that GNAT implements an unusual rule for
1050          case folding.  For ASCII letters, letters in single-byte
1051          encodings (such as ISO-8859-*), and Unicode letters that fit
1052          in a single byte (i.e., code point is <= 0xff), the letter is
1053          folded to lower case.  Other Unicode letters are folded to
1054          upper case.
1055
1056          This rule means that the code must be able to examine the
1057          value of the character.  And, some hosts do not use Unicode
1058          for wchar_t, so examining the value of such characters is
1059          forbidden.  */
1060       auto_obstack storage;
1061       try
1062         {
1063           convert_between_encodings
1064             (host_charset (), HOST_UTF32,
1065              (const gdb_byte *) name.data (),
1066              name.length (), 1,
1067              &storage, translit_none);
1068         }
1069       catch (const gdb_exception &)
1070         {
1071           if (throw_on_error)
1072             throw;
1073
1074           static bool warned = false;
1075
1076           /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
1077              might like to know why.  */
1078           if (!warned)
1079             {
1080               warned = true;
1081               warning (_("could not convert '%s' from the host encoding (%s) to UTF-32.\n"
1082                          "This normally should not happen, please file a bug report."),
1083                        gdb::to_string (name).c_str (), host_charset ());
1084             }
1085
1086           /* We don't try to recover from errors; just return the
1087              original string.  */
1088           fold_storage = gdb::to_string (name);
1089           return fold_storage.c_str ();
1090         }
1091
1092       bool is_utf8 = ada_source_charset == ada_utf8;
1093       uint32_t *chars = (uint32_t *) obstack_base (&storage);
1094       int num_chars = obstack_object_size (&storage) / sizeof (uint32_t);
1095       for (int i = 0; i < num_chars; ++i)
1096         {
1097           const struct utf8_entry *entry = find_case_fold_entry (chars[i]);
1098           if (entry != nullptr)
1099             {
1100               uint32_t low = chars[i] + entry->lower_delta;
1101               if (!is_utf8 || low <= 0xff)
1102                 chars[i] = low;
1103               else
1104                 chars[i] = chars[i] + entry->upper_delta;
1105             }
1106         }
1107
1108       /* Now convert back to ordinary characters.  */
1109       auto_obstack reconverted;
1110       try
1111         {
1112           convert_between_encodings (HOST_UTF32,
1113                                      host_charset (),
1114                                      (const gdb_byte *) chars,
1115                                      num_chars * sizeof (uint32_t),
1116                                      sizeof (uint32_t),
1117                                      &reconverted,
1118                                      translit_none);
1119           obstack_1grow (&reconverted, '\0');
1120           fold_storage = std::string ((const char *) obstack_base (&reconverted));
1121         }
1122       catch (const gdb_exception &)
1123         {
1124           if (throw_on_error)
1125             throw;
1126
1127           static bool warned = false;
1128
1129           /* Converting back from UTF-32 shouldn't normally fail, but
1130              there are some host encodings without upper/lower
1131              equivalence.  */
1132           if (!warned)
1133             {
1134               warned = true;
1135               warning (_("could not convert the lower-cased variant of '%s'\n"
1136                          "from UTF-32 to the host encoding (%s)."),
1137                        gdb::to_string (name).c_str (), host_charset ());
1138             }
1139
1140           /* We don't try to recover from errors; just return the
1141              original string.  */
1142           fold_storage = gdb::to_string (name);
1143         }
1144     }
1145
1146   return fold_storage.c_str ();
1147 }
1148
1149 /* The "encoded" form of DECODED, according to GNAT conventions.  */
1150
1151 std::string
1152 ada_encode (const char *decoded)
1153 {
1154   if (decoded[0] != '<')
1155     decoded = ada_fold_name (decoded);
1156   return ada_encode_1 (decoded, true);
1157 }
1158
1159 /* Return nonzero if C is either a digit or a lowercase alphabet character.  */
1160
1161 static int
1162 is_lower_alphanum (const char c)
1163 {
1164   return (isdigit (c) || (isalpha (c) && islower (c)));
1165 }
1166
1167 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1168    This function saves in LEN the length of that same symbol name but
1169    without either of these suffixes:
1170      . .{DIGIT}+
1171      . ${DIGIT}+
1172      . ___{DIGIT}+
1173      . __{DIGIT}+.
1174
1175    These are suffixes introduced by the compiler for entities such as
1176    nested subprogram for instance, in order to avoid name clashes.
1177    They do not serve any purpose for the debugger.  */
1178
1179 static void
1180 ada_remove_trailing_digits (const char *encoded, int *len)
1181 {
1182   if (*len > 1 && isdigit (encoded[*len - 1]))
1183     {
1184       int i = *len - 2;
1185
1186       while (i > 0 && isdigit (encoded[i]))
1187         i--;
1188       if (i >= 0 && encoded[i] == '.')
1189         *len = i;
1190       else if (i >= 0 && encoded[i] == '$')
1191         *len = i;
1192       else if (i >= 2 && startswith (encoded + i - 2, "___"))
1193         *len = i - 2;
1194       else if (i >= 1 && startswith (encoded + i - 1, "__"))
1195         *len = i - 1;
1196     }
1197 }
1198
1199 /* Remove the suffix introduced by the compiler for protected object
1200    subprograms.  */
1201
1202 static void
1203 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1204 {
1205   /* Remove trailing N.  */
1206
1207   /* Protected entry subprograms are broken into two
1208      separate subprograms: The first one is unprotected, and has
1209      a 'N' suffix; the second is the protected version, and has
1210      the 'P' suffix.  The second calls the first one after handling
1211      the protection.  Since the P subprograms are internally generated,
1212      we leave these names undecoded, giving the user a clue that this
1213      entity is internal.  */
1214
1215   if (*len > 1
1216       && encoded[*len - 1] == 'N'
1217       && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1218     *len = *len - 1;
1219 }
1220
1221 /* If ENCODED ends with a compiler-provided suffix (like ".cold"),
1222    then update *LEN to remove the suffix and return the offset of the
1223    character just past the ".".  Otherwise, return -1.  */
1224
1225 static int
1226 remove_compiler_suffix (const char *encoded, int *len)
1227 {
1228   int offset = *len - 1;
1229   while (offset > 0 && isalpha (encoded[offset]))
1230     --offset;
1231   if (offset > 0 && encoded[offset] == '.')
1232     {
1233       *len = offset;
1234       return offset + 1;
1235     }
1236   return -1;
1237 }
1238
1239 /* Convert an ASCII hex string to a number.  Reads exactly N
1240    characters from STR.  Returns true on success, false if one of the
1241    digits was not a hex digit.  */
1242 static bool
1243 convert_hex (const char *str, int n, uint32_t *out)
1244 {
1245   uint32_t result = 0;
1246
1247   for (int i = 0; i < n; ++i)
1248     {
1249       if (!isxdigit (str[i]))
1250         return false;
1251       result <<= 4;
1252       result |= fromhex (str[i]);
1253     }
1254
1255   *out = result;
1256   return true;
1257 }
1258
1259 /* Convert a wide character from its ASCII hex representation in STR
1260    (consisting of exactly N characters) to the host encoding,
1261    appending the resulting bytes to OUT.  If N==2 and the Ada source
1262    charset is not UTF-8, then hex refers to an encoding in the
1263    ADA_SOURCE_CHARSET; otherwise, use UTF-32.  Return true on success.
1264    Return false and do not modify OUT on conversion failure.  */
1265 static bool
1266 convert_from_hex_encoded (std::string &out, const char *str, int n)
1267 {
1268   uint32_t value;
1269
1270   if (!convert_hex (str, n, &value))
1271     return false;
1272   try
1273     {
1274       auto_obstack bytes;
1275       /* In the 'U' case, the hex digits encode the character in the
1276          Ada source charset.  However, if the source charset is UTF-8,
1277          this really means it is a single-byte UTF-32 character.  */
1278       if (n == 2 && ada_source_charset != ada_utf8)
1279         {
1280           gdb_byte one_char = (gdb_byte) value;
1281
1282           convert_between_encodings (ada_source_charset, host_charset (),
1283                                      &one_char,
1284                                      sizeof (one_char), sizeof (one_char),
1285                                      &bytes, translit_none);
1286         }
1287       else
1288         convert_between_encodings (HOST_UTF32, host_charset (),
1289                                    (const gdb_byte *) &value,
1290                                    sizeof (value), sizeof (value),
1291                                    &bytes, translit_none);
1292       obstack_1grow (&bytes, '\0');
1293       out.append ((const char *) obstack_base (&bytes));
1294     }
1295   catch (const gdb_exception &)
1296     {
1297       /* On failure, the caller will just let the encoded form
1298          through, which seems basically reasonable.  */
1299       return false;
1300     }
1301
1302   return true;
1303 }
1304
1305 /* See ada-lang.h.  */
1306
1307 std::string
1308 ada_decode (const char *encoded, bool wrap, bool operators)
1309 {
1310   int i;
1311   int len0;
1312   const char *p;
1313   int at_start_name;
1314   std::string decoded;
1315   int suffix = -1;
1316
1317   /* With function descriptors on PPC64, the value of a symbol named
1318      ".FN", if it exists, is the entry point of the function "FN".  */
1319   if (encoded[0] == '.')
1320     encoded += 1;
1321
1322   /* The name of the Ada main procedure starts with "_ada_".
1323      This prefix is not part of the decoded name, so skip this part
1324      if we see this prefix.  */
1325   if (startswith (encoded, "_ada_"))
1326     encoded += 5;
1327   /* The "___ghost_" prefix is used for ghost entities.  Normally
1328      these aren't preserved but when they are, it's useful to see
1329      them.  */
1330   if (startswith (encoded, "___ghost_"))
1331     encoded += 9;
1332
1333   /* If the name starts with '_', then it is not a properly encoded
1334      name, so do not attempt to decode it.  Similarly, if the name
1335      starts with '<', the name should not be decoded.  */
1336   if (encoded[0] == '_' || encoded[0] == '<')
1337     goto Suppress;
1338
1339   len0 = strlen (encoded);
1340
1341   suffix = remove_compiler_suffix (encoded, &len0);
1342
1343   ada_remove_trailing_digits (encoded, &len0);
1344   ada_remove_po_subprogram_suffix (encoded, &len0);
1345
1346   /* Remove the ___X.* suffix if present.  Do not forget to verify that
1347      the suffix is located before the current "end" of ENCODED.  We want
1348      to avoid re-matching parts of ENCODED that have previously been
1349      marked as discarded (by decrementing LEN0).  */
1350   p = strstr (encoded, "___");
1351   if (p != NULL && p - encoded < len0 - 3)
1352     {
1353       if (p[3] == 'X')
1354         len0 = p - encoded;
1355       else
1356         goto Suppress;
1357     }
1358
1359   /* Remove any trailing TKB suffix.  It tells us that this symbol
1360      is for the body of a task, but that information does not actually
1361      appear in the decoded name.  */
1362
1363   if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1364     len0 -= 3;
1365
1366   /* Remove any trailing TB suffix.  The TB suffix is slightly different
1367      from the TKB suffix because it is used for non-anonymous task
1368      bodies.  */
1369
1370   if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1371     len0 -= 2;
1372
1373   /* Remove trailing "B" suffixes.  */
1374   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
1375
1376   if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1377     len0 -= 1;
1378
1379   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
1380
1381   if (len0 > 1 && isdigit (encoded[len0 - 1]))
1382     {
1383       i = len0 - 2;
1384       while ((i >= 0 && isdigit (encoded[i]))
1385              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1386         i -= 1;
1387       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1388         len0 = i - 1;
1389       else if (encoded[i] == '$')
1390         len0 = i;
1391     }
1392
1393   /* The first few characters that are not alphabetic are not part
1394      of any encoding we use, so we can copy them over verbatim.  */
1395
1396   for (i = 0; i < len0 && !isalpha (encoded[i]); i += 1)
1397     decoded.push_back (encoded[i]);
1398
1399   at_start_name = 1;
1400   while (i < len0)
1401     {
1402       /* Is this a symbol function?  */
1403       if (operators && at_start_name && encoded[i] == 'O')
1404         {
1405           int k;
1406
1407           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1408             {
1409               int op_len = strlen (ada_opname_table[k].encoded);
1410               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1411                             op_len - 1) == 0)
1412                   && !isalnum (encoded[i + op_len]))
1413                 {
1414                   decoded.append (ada_opname_table[k].decoded);
1415                   at_start_name = 0;
1416                   i += op_len;
1417                   break;
1418                 }
1419             }
1420           if (ada_opname_table[k].encoded != NULL)
1421             continue;
1422         }
1423       at_start_name = 0;
1424
1425       /* Replace "TK__" with "__", which will eventually be translated
1426          into "." (just below).  */
1427
1428       if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1429         i += 2;
1430
1431       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1432          be translated into "." (just below).  These are internal names
1433          generated for anonymous blocks inside which our symbol is nested.  */
1434
1435       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1436           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1437           && isdigit (encoded [i+4]))
1438         {
1439           int k = i + 5;
1440           
1441           while (k < len0 && isdigit (encoded[k]))
1442             k++;  /* Skip any extra digit.  */
1443
1444           /* Double-check that the "__B_{DIGITS}+" sequence we found
1445              is indeed followed by "__".  */
1446           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1447             i = k;
1448         }
1449
1450       /* Remove _E{DIGITS}+[sb] */
1451
1452       /* Just as for protected object subprograms, there are 2 categories
1453          of subprograms created by the compiler for each entry.  The first
1454          one implements the actual entry code, and has a suffix following
1455          the convention above; the second one implements the barrier and
1456          uses the same convention as above, except that the 'E' is replaced
1457          by a 'B'.
1458
1459          Just as above, we do not decode the name of barrier functions
1460          to give the user a clue that the code he is debugging has been
1461          internally generated.  */
1462
1463       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1464           && isdigit (encoded[i+2]))
1465         {
1466           int k = i + 3;
1467
1468           while (k < len0 && isdigit (encoded[k]))
1469             k++;
1470
1471           if (k < len0
1472               && (encoded[k] == 'b' || encoded[k] == 's'))
1473             {
1474               k++;
1475               /* Just as an extra precaution, make sure that if this
1476                  suffix is followed by anything else, it is a '_'.
1477                  Otherwise, we matched this sequence by accident.  */
1478               if (k == len0
1479                   || (k < len0 && encoded[k] == '_'))
1480                 i = k;
1481             }
1482         }
1483
1484       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1485          the GNAT front-end in protected object subprograms.  */
1486
1487       if (i < len0 + 3
1488           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1489         {
1490           /* Backtrack a bit up until we reach either the begining of
1491              the encoded name, or "__".  Make sure that we only find
1492              digits or lowercase characters.  */
1493           const char *ptr = encoded + i - 1;
1494
1495           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1496             ptr--;
1497           if (ptr < encoded
1498               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1499             i++;
1500         }
1501
1502       if (i < len0 + 3 && encoded[i] == 'U' && isxdigit (encoded[i + 1]))
1503         {
1504           if (convert_from_hex_encoded (decoded, &encoded[i + 1], 2))
1505             {
1506               i += 3;
1507               continue;
1508             }
1509         }
1510       else if (i < len0 + 5 && encoded[i] == 'W' && isxdigit (encoded[i + 1]))
1511         {
1512           if (convert_from_hex_encoded (decoded, &encoded[i + 1], 4))
1513             {
1514               i += 5;
1515               continue;
1516             }
1517         }
1518       else if (i < len0 + 10 && encoded[i] == 'W' && encoded[i + 1] == 'W'
1519                && isxdigit (encoded[i + 2]))
1520         {
1521           if (convert_from_hex_encoded (decoded, &encoded[i + 2], 8))
1522             {
1523               i += 10;
1524               continue;
1525             }
1526         }
1527
1528       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1529         {
1530           /* This is a X[bn]* sequence not separated from the previous
1531              part of the name with a non-alpha-numeric character (in other
1532              words, immediately following an alpha-numeric character), then
1533              verify that it is placed at the end of the encoded name.  If
1534              not, then the encoding is not valid and we should abort the
1535              decoding.  Otherwise, just skip it, it is used in body-nested
1536              package names.  */
1537           do
1538             i += 1;
1539           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1540           if (i < len0)
1541             goto Suppress;
1542         }
1543       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1544         {
1545          /* Replace '__' by '.'.  */
1546           decoded.push_back ('.');
1547           at_start_name = 1;
1548           i += 2;
1549         }
1550       else
1551         {
1552           /* It's a character part of the decoded name, so just copy it
1553              over.  */
1554           decoded.push_back (encoded[i]);
1555           i += 1;
1556         }
1557     }
1558
1559   /* Decoded names should never contain any uppercase character.
1560      Double-check this, and abort the decoding if we find one.  */
1561
1562   if (operators)
1563     {
1564       for (i = 0; i < decoded.length(); ++i)
1565         if (isupper (decoded[i]) || decoded[i] == ' ')
1566           goto Suppress;
1567     }
1568
1569   /* If the compiler added a suffix, append it now.  */
1570   if (suffix >= 0)
1571     decoded = decoded + "[" + &encoded[suffix] + "]";
1572
1573   return decoded;
1574
1575 Suppress:
1576   if (!wrap)
1577     return {};
1578
1579   if (encoded[0] == '<')
1580     decoded = encoded;
1581   else
1582     decoded = '<' + std::string(encoded) + '>';
1583   return decoded;
1584 }
1585
1586 /* Table for keeping permanent unique copies of decoded names.  Once
1587    allocated, names in this table are never released.  While this is a
1588    storage leak, it should not be significant unless there are massive
1589    changes in the set of decoded names in successive versions of a 
1590    symbol table loaded during a single session.  */
1591 static struct htab *decoded_names_store;
1592
1593 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1594    in the language-specific part of GSYMBOL, if it has not been
1595    previously computed.  Tries to save the decoded name in the same
1596    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1597    in any case, the decoded symbol has a lifetime at least that of
1598    GSYMBOL).
1599    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1600    const, but nevertheless modified to a semantically equivalent form
1601    when a decoded name is cached in it.  */
1602
1603 const char *
1604 ada_decode_symbol (const struct general_symbol_info *arg)
1605 {
1606   struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1607   const char **resultp =
1608     &gsymbol->language_specific.demangled_name;
1609
1610   if (!gsymbol->ada_mangled)
1611     {
1612       std::string decoded = ada_decode (gsymbol->linkage_name ());
1613       struct obstack *obstack = gsymbol->language_specific.obstack;
1614
1615       gsymbol->ada_mangled = 1;
1616
1617       if (obstack != NULL)
1618         *resultp = obstack_strdup (obstack, decoded.c_str ());
1619       else
1620         {
1621           /* Sometimes, we can't find a corresponding objfile, in
1622              which case, we put the result on the heap.  Since we only
1623              decode when needed, we hope this usually does not cause a
1624              significant memory leak (FIXME).  */
1625
1626           char **slot = (char **) htab_find_slot (decoded_names_store,
1627                                                   decoded.c_str (), INSERT);
1628
1629           if (*slot == NULL)
1630             *slot = xstrdup (decoded.c_str ());
1631           *resultp = *slot;
1632         }
1633     }
1634
1635   return *resultp;
1636 }
1637
1638 \f
1639
1640                                 /* Arrays */
1641
1642 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1643    generated by the GNAT compiler to describe the index type used
1644    for each dimension of an array, check whether it follows the latest
1645    known encoding.  If not, fix it up to conform to the latest encoding.
1646    Otherwise, do nothing.  This function also does nothing if
1647    INDEX_DESC_TYPE is NULL.
1648
1649    The GNAT encoding used to describe the array index type evolved a bit.
1650    Initially, the information would be provided through the name of each
1651    field of the structure type only, while the type of these fields was
1652    described as unspecified and irrelevant.  The debugger was then expected
1653    to perform a global type lookup using the name of that field in order
1654    to get access to the full index type description.  Because these global
1655    lookups can be very expensive, the encoding was later enhanced to make
1656    the global lookup unnecessary by defining the field type as being
1657    the full index type description.
1658
1659    The purpose of this routine is to allow us to support older versions
1660    of the compiler by detecting the use of the older encoding, and by
1661    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1662    we essentially replace each field's meaningless type by the associated
1663    index subtype).  */
1664
1665 void
1666 ada_fixup_array_indexes_type (struct type *index_desc_type)
1667 {
1668   int i;
1669
1670   if (index_desc_type == NULL)
1671     return;
1672   gdb_assert (index_desc_type->num_fields () > 0);
1673
1674   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1675      to check one field only, no need to check them all).  If not, return
1676      now.
1677
1678      If our INDEX_DESC_TYPE was generated using the older encoding,
1679      the field type should be a meaningless integer type whose name
1680      is not equal to the field name.  */
1681   if (index_desc_type->field (0).type ()->name () != NULL
1682       && strcmp (index_desc_type->field (0).type ()->name (),
1683                  index_desc_type->field (0).name ()) == 0)
1684     return;
1685
1686   /* Fixup each field of INDEX_DESC_TYPE.  */
1687   for (i = 0; i < index_desc_type->num_fields (); i++)
1688    {
1689      const char *name = index_desc_type->field (i).name ();
1690      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1691
1692      if (raw_type)
1693        index_desc_type->field (i).set_type (raw_type);
1694    }
1695 }
1696
1697 /* The desc_* routines return primitive portions of array descriptors
1698    (fat pointers).  */
1699
1700 /* The descriptor or array type, if any, indicated by TYPE; removes
1701    level of indirection, if needed.  */
1702
1703 static struct type *
1704 desc_base_type (struct type *type)
1705 {
1706   if (type == NULL)
1707     return NULL;
1708   type = ada_check_typedef (type);
1709   if (type->code () == TYPE_CODE_TYPEDEF)
1710     type = ada_typedef_target_type (type);
1711
1712   if (type != NULL
1713       && (type->code () == TYPE_CODE_PTR
1714           || type->code () == TYPE_CODE_REF))
1715     return ada_check_typedef (type->target_type ());
1716   else
1717     return type;
1718 }
1719
1720 /* True iff TYPE indicates a "thin" array pointer type.  */
1721
1722 static int
1723 is_thin_pntr (struct type *type)
1724 {
1725   return
1726     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1727     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1728 }
1729
1730 /* The descriptor type for thin pointer type TYPE.  */
1731
1732 static struct type *
1733 thin_descriptor_type (struct type *type)
1734 {
1735   struct type *base_type = desc_base_type (type);
1736
1737   if (base_type == NULL)
1738     return NULL;
1739   if (is_suffix (ada_type_name (base_type), "___XVE"))
1740     return base_type;
1741   else
1742     {
1743       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1744
1745       if (alt_type == NULL)
1746         return base_type;
1747       else
1748         return alt_type;
1749     }
1750 }
1751
1752 /* A pointer to the array data for thin-pointer value VAL.  */
1753
1754 static struct value *
1755 thin_data_pntr (struct value *val)
1756 {
1757   struct type *type = ada_check_typedef (value_type (val));
1758   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1759
1760   data_type = lookup_pointer_type (data_type);
1761
1762   if (type->code () == TYPE_CODE_PTR)
1763     return value_cast (data_type, value_copy (val));
1764   else
1765     return value_from_longest (data_type, value_address (val));
1766 }
1767
1768 /* True iff TYPE indicates a "thick" array pointer type.  */
1769
1770 static int
1771 is_thick_pntr (struct type *type)
1772 {
1773   type = desc_base_type (type);
1774   return (type != NULL && type->code () == TYPE_CODE_STRUCT
1775           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1776 }
1777
1778 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1779    pointer to one, the type of its bounds data; otherwise, NULL.  */
1780
1781 static struct type *
1782 desc_bounds_type (struct type *type)
1783 {
1784   struct type *r;
1785
1786   type = desc_base_type (type);
1787
1788   if (type == NULL)
1789     return NULL;
1790   else if (is_thin_pntr (type))
1791     {
1792       type = thin_descriptor_type (type);
1793       if (type == NULL)
1794         return NULL;
1795       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1796       if (r != NULL)
1797         return ada_check_typedef (r);
1798     }
1799   else if (type->code () == TYPE_CODE_STRUCT)
1800     {
1801       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1802       if (r != NULL)
1803         return ada_check_typedef (ada_check_typedef (r)->target_type ());
1804     }
1805   return NULL;
1806 }
1807
1808 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1809    one, a pointer to its bounds data.   Otherwise NULL.  */
1810
1811 static struct value *
1812 desc_bounds (struct value *arr)
1813 {
1814   struct type *type = ada_check_typedef (value_type (arr));
1815
1816   if (is_thin_pntr (type))
1817     {
1818       struct type *bounds_type =
1819         desc_bounds_type (thin_descriptor_type (type));
1820       LONGEST addr;
1821
1822       if (bounds_type == NULL)
1823         error (_("Bad GNAT array descriptor"));
1824
1825       /* NOTE: The following calculation is not really kosher, but
1826          since desc_type is an XVE-encoded type (and shouldn't be),
1827          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1828       if (type->code () == TYPE_CODE_PTR)
1829         addr = value_as_long (arr);
1830       else
1831         addr = value_address (arr);
1832
1833       return
1834         value_from_longest (lookup_pointer_type (bounds_type),
1835                             addr - bounds_type->length ());
1836     }
1837
1838   else if (is_thick_pntr (type))
1839     {
1840       struct value *p_bounds = value_struct_elt (&arr, {}, "P_BOUNDS", NULL,
1841                                                _("Bad GNAT array descriptor"));
1842       struct type *p_bounds_type = value_type (p_bounds);
1843
1844       if (p_bounds_type
1845           && p_bounds_type->code () == TYPE_CODE_PTR)
1846         {
1847           struct type *target_type = p_bounds_type->target_type ();
1848
1849           if (target_type->is_stub ())
1850             p_bounds = value_cast (lookup_pointer_type
1851                                    (ada_check_typedef (target_type)),
1852                                    p_bounds);
1853         }
1854       else
1855         error (_("Bad GNAT array descriptor"));
1856
1857       return p_bounds;
1858     }
1859   else
1860     return NULL;
1861 }
1862
1863 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1864    position of the field containing the address of the bounds data.  */
1865
1866 static int
1867 fat_pntr_bounds_bitpos (struct type *type)
1868 {
1869   return desc_base_type (type)->field (1).loc_bitpos ();
1870 }
1871
1872 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1873    size of the field containing the address of the bounds data.  */
1874
1875 static int
1876 fat_pntr_bounds_bitsize (struct type *type)
1877 {
1878   type = desc_base_type (type);
1879
1880   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1881     return TYPE_FIELD_BITSIZE (type, 1);
1882   else
1883     return 8 * ada_check_typedef (type->field (1).type ())->length ();
1884 }
1885
1886 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1887    pointer to one, the type of its array data (a array-with-no-bounds type);
1888    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1889    data.  */
1890
1891 static struct type *
1892 desc_data_target_type (struct type *type)
1893 {
1894   type = desc_base_type (type);
1895
1896   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1897   if (is_thin_pntr (type))
1898     return desc_base_type (thin_descriptor_type (type)->field (1).type ());
1899   else if (is_thick_pntr (type))
1900     {
1901       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1902
1903       if (data_type
1904           && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
1905         return ada_check_typedef (data_type->target_type ());
1906     }
1907
1908   return NULL;
1909 }
1910
1911 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1912    its array data.  */
1913
1914 static struct value *
1915 desc_data (struct value *arr)
1916 {
1917   struct type *type = value_type (arr);
1918
1919   if (is_thin_pntr (type))
1920     return thin_data_pntr (arr);
1921   else if (is_thick_pntr (type))
1922     return value_struct_elt (&arr, {}, "P_ARRAY", NULL,
1923                              _("Bad GNAT array descriptor"));
1924   else
1925     return NULL;
1926 }
1927
1928
1929 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1930    position of the field containing the address of the data.  */
1931
1932 static int
1933 fat_pntr_data_bitpos (struct type *type)
1934 {
1935   return desc_base_type (type)->field (0).loc_bitpos ();
1936 }
1937
1938 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1939    size of the field containing the address of the data.  */
1940
1941 static int
1942 fat_pntr_data_bitsize (struct type *type)
1943 {
1944   type = desc_base_type (type);
1945
1946   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1947     return TYPE_FIELD_BITSIZE (type, 0);
1948   else
1949     return TARGET_CHAR_BIT * type->field (0).type ()->length ();
1950 }
1951
1952 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1953    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1954    bound, if WHICH is 1.  The first bound is I=1.  */
1955
1956 static struct value *
1957 desc_one_bound (struct value *bounds, int i, int which)
1958 {
1959   char bound_name[20];
1960   xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
1961              which ? 'U' : 'L', i - 1);
1962   return value_struct_elt (&bounds, {}, bound_name, NULL,
1963                            _("Bad GNAT array descriptor bounds"));
1964 }
1965
1966 /* If BOUNDS is an array-bounds structure type, return the bit position
1967    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1968    bound, if WHICH is 1.  The first bound is I=1.  */
1969
1970 static int
1971 desc_bound_bitpos (struct type *type, int i, int which)
1972 {
1973   return desc_base_type (type)->field (2 * i + which - 2).loc_bitpos ();
1974 }
1975
1976 /* If BOUNDS is an array-bounds structure type, return the bit field size
1977    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1978    bound, if WHICH is 1.  The first bound is I=1.  */
1979
1980 static int
1981 desc_bound_bitsize (struct type *type, int i, int which)
1982 {
1983   type = desc_base_type (type);
1984
1985   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1986     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1987   else
1988     return 8 * type->field (2 * i + which - 2).type ()->length ();
1989 }
1990
1991 /* If TYPE is the type of an array-bounds structure, the type of its
1992    Ith bound (numbering from 1).  Otherwise, NULL.  */
1993
1994 static struct type *
1995 desc_index_type (struct type *type, int i)
1996 {
1997   type = desc_base_type (type);
1998
1999   if (type->code () == TYPE_CODE_STRUCT)
2000     {
2001       char bound_name[20];
2002       xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
2003       return lookup_struct_elt_type (type, bound_name, 1);
2004     }
2005   else
2006     return NULL;
2007 }
2008
2009 /* The number of index positions in the array-bounds type TYPE.
2010    Return 0 if TYPE is NULL.  */
2011
2012 static int
2013 desc_arity (struct type *type)
2014 {
2015   type = desc_base_type (type);
2016
2017   if (type != NULL)
2018     return type->num_fields () / 2;
2019   return 0;
2020 }
2021
2022 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
2023    an array descriptor type (representing an unconstrained array
2024    type).  */
2025
2026 static int
2027 ada_is_direct_array_type (struct type *type)
2028 {
2029   if (type == NULL)
2030     return 0;
2031   type = ada_check_typedef (type);
2032   return (type->code () == TYPE_CODE_ARRAY
2033           || ada_is_array_descriptor_type (type));
2034 }
2035
2036 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
2037  * to one.  */
2038
2039 static int
2040 ada_is_array_type (struct type *type)
2041 {
2042   while (type != NULL
2043          && (type->code () == TYPE_CODE_PTR
2044              || type->code () == TYPE_CODE_REF))
2045     type = type->target_type ();
2046   return ada_is_direct_array_type (type);
2047 }
2048
2049 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
2050
2051 int
2052 ada_is_simple_array_type (struct type *type)
2053 {
2054   if (type == NULL)
2055     return 0;
2056   type = ada_check_typedef (type);
2057   return (type->code () == TYPE_CODE_ARRAY
2058           || (type->code () == TYPE_CODE_PTR
2059               && (ada_check_typedef (type->target_type ())->code ()
2060                   == TYPE_CODE_ARRAY)));
2061 }
2062
2063 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
2064
2065 int
2066 ada_is_array_descriptor_type (struct type *type)
2067 {
2068   struct type *data_type = desc_data_target_type (type);
2069
2070   if (type == NULL)
2071     return 0;
2072   type = ada_check_typedef (type);
2073   return (data_type != NULL
2074           && data_type->code () == TYPE_CODE_ARRAY
2075           && desc_arity (desc_bounds_type (type)) > 0);
2076 }
2077
2078 /* Non-zero iff type is a partially mal-formed GNAT array
2079    descriptor.  FIXME: This is to compensate for some problems with
2080    debugging output from GNAT.  Re-examine periodically to see if it
2081    is still needed.  */
2082
2083 int
2084 ada_is_bogus_array_descriptor (struct type *type)
2085 {
2086   return
2087     type != NULL
2088     && type->code () == TYPE_CODE_STRUCT
2089     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
2090         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
2091     && !ada_is_array_descriptor_type (type);
2092 }
2093
2094
2095 /* If ARR has a record type in the form of a standard GNAT array descriptor,
2096    (fat pointer) returns the type of the array data described---specifically,
2097    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
2098    in from the descriptor; otherwise, they are left unspecified.  If
2099    the ARR denotes a null array descriptor and BOUNDS is non-zero,
2100    returns NULL.  The result is simply the type of ARR if ARR is not
2101    a descriptor.  */
2102
2103 static struct type *
2104 ada_type_of_array (struct value *arr, int bounds)
2105 {
2106   if (ada_is_constrained_packed_array_type (value_type (arr)))
2107     return decode_constrained_packed_array_type (value_type (arr));
2108
2109   if (!ada_is_array_descriptor_type (value_type (arr)))
2110     return value_type (arr);
2111
2112   if (!bounds)
2113     {
2114       struct type *array_type =
2115         ada_check_typedef (desc_data_target_type (value_type (arr)));
2116
2117       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2118         TYPE_FIELD_BITSIZE (array_type, 0) =
2119           decode_packed_array_bitsize (value_type (arr));
2120       
2121       return array_type;
2122     }
2123   else
2124     {
2125       struct type *elt_type;
2126       int arity;
2127       struct value *descriptor;
2128
2129       elt_type = ada_array_element_type (value_type (arr), -1);
2130       arity = ada_array_arity (value_type (arr));
2131
2132       if (elt_type == NULL || arity == 0)
2133         return ada_check_typedef (value_type (arr));
2134
2135       descriptor = desc_bounds (arr);
2136       if (value_as_long (descriptor) == 0)
2137         return NULL;
2138       while (arity > 0)
2139         {
2140           struct type *range_type = alloc_type_copy (value_type (arr));
2141           struct type *array_type = alloc_type_copy (value_type (arr));
2142           struct value *low = desc_one_bound (descriptor, arity, 0);
2143           struct value *high = desc_one_bound (descriptor, arity, 1);
2144
2145           arity -= 1;
2146           create_static_range_type (range_type, value_type (low),
2147                                     longest_to_int (value_as_long (low)),
2148                                     longest_to_int (value_as_long (high)));
2149           elt_type = create_array_type (array_type, elt_type, range_type);
2150
2151           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2152             {
2153               /* We need to store the element packed bitsize, as well as
2154                  recompute the array size, because it was previously
2155                  computed based on the unpacked element size.  */
2156               LONGEST lo = value_as_long (low);
2157               LONGEST hi = value_as_long (high);
2158
2159               TYPE_FIELD_BITSIZE (elt_type, 0) =
2160                 decode_packed_array_bitsize (value_type (arr));
2161               /* If the array has no element, then the size is already
2162                  zero, and does not need to be recomputed.  */
2163               if (lo < hi)
2164                 {
2165                   int array_bitsize =
2166                         (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2167
2168                   array_type->set_length ((array_bitsize + 7) / 8);
2169                 }
2170             }
2171         }
2172
2173       return lookup_pointer_type (elt_type);
2174     }
2175 }
2176
2177 /* If ARR does not represent an array, returns ARR unchanged.
2178    Otherwise, returns either a standard GDB array with bounds set
2179    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2180    GDB array.  Returns NULL if ARR is a null fat pointer.  */
2181
2182 struct value *
2183 ada_coerce_to_simple_array_ptr (struct value *arr)
2184 {
2185   if (ada_is_array_descriptor_type (value_type (arr)))
2186     {
2187       struct type *arrType = ada_type_of_array (arr, 1);
2188
2189       if (arrType == NULL)
2190         return NULL;
2191       return value_cast (arrType, value_copy (desc_data (arr)));
2192     }
2193   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2194     return decode_constrained_packed_array (arr);
2195   else
2196     return arr;
2197 }
2198
2199 /* If ARR does not represent an array, returns ARR unchanged.
2200    Otherwise, returns a standard GDB array describing ARR (which may
2201    be ARR itself if it already is in the proper form).  */
2202
2203 struct value *
2204 ada_coerce_to_simple_array (struct value *arr)
2205 {
2206   if (ada_is_array_descriptor_type (value_type (arr)))
2207     {
2208       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2209
2210       if (arrVal == NULL)
2211         error (_("Bounds unavailable for null array pointer."));
2212       return value_ind (arrVal);
2213     }
2214   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2215     return decode_constrained_packed_array (arr);
2216   else
2217     return arr;
2218 }
2219
2220 /* If TYPE represents a GNAT array type, return it translated to an
2221    ordinary GDB array type (possibly with BITSIZE fields indicating
2222    packing).  For other types, is the identity.  */
2223
2224 struct type *
2225 ada_coerce_to_simple_array_type (struct type *type)
2226 {
2227   if (ada_is_constrained_packed_array_type (type))
2228     return decode_constrained_packed_array_type (type);
2229
2230   if (ada_is_array_descriptor_type (type))
2231     return ada_check_typedef (desc_data_target_type (type));
2232
2233   return type;
2234 }
2235
2236 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
2237
2238 static int
2239 ada_is_gnat_encoded_packed_array_type  (struct type *type)
2240 {
2241   if (type == NULL)
2242     return 0;
2243   type = desc_base_type (type);
2244   type = ada_check_typedef (type);
2245   return
2246     ada_type_name (type) != NULL
2247     && strstr (ada_type_name (type), "___XP") != NULL;
2248 }
2249
2250 /* Non-zero iff TYPE represents a standard GNAT constrained
2251    packed-array type.  */
2252
2253 int
2254 ada_is_constrained_packed_array_type (struct type *type)
2255 {
2256   return ada_is_gnat_encoded_packed_array_type (type)
2257     && !ada_is_array_descriptor_type (type);
2258 }
2259
2260 /* Non-zero iff TYPE represents an array descriptor for a
2261    unconstrained packed-array type.  */
2262
2263 static int
2264 ada_is_unconstrained_packed_array_type (struct type *type)
2265 {
2266   if (!ada_is_array_descriptor_type (type))
2267     return 0;
2268
2269   if (ada_is_gnat_encoded_packed_array_type (type))
2270     return 1;
2271
2272   /* If we saw GNAT encodings, then the above code is sufficient.
2273      However, with minimal encodings, we will just have a thick
2274      pointer instead.  */
2275   if (is_thick_pntr (type))
2276     {
2277       type = desc_base_type (type);
2278       /* The structure's first field is a pointer to an array, so this
2279          fetches the array type.  */
2280       type = type->field (0).type ()->target_type ();
2281       if (type->code () == TYPE_CODE_TYPEDEF)
2282         type = ada_typedef_target_type (type);
2283       /* Now we can see if the array elements are packed.  */
2284       return TYPE_FIELD_BITSIZE (type, 0) > 0;
2285     }
2286
2287   return 0;
2288 }
2289
2290 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
2291    type, or if it is an ordinary (non-Gnat-encoded) packed array.  */
2292
2293 static bool
2294 ada_is_any_packed_array_type (struct type *type)
2295 {
2296   return (ada_is_constrained_packed_array_type (type)
2297           || (type->code () == TYPE_CODE_ARRAY
2298               && TYPE_FIELD_BITSIZE (type, 0) % 8 != 0));
2299 }
2300
2301 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2302    return the size of its elements in bits.  */
2303
2304 static long
2305 decode_packed_array_bitsize (struct type *type)
2306 {
2307   const char *raw_name;
2308   const char *tail;
2309   long bits;
2310
2311   /* Access to arrays implemented as fat pointers are encoded as a typedef
2312      of the fat pointer type.  We need the name of the fat pointer type
2313      to do the decoding, so strip the typedef layer.  */
2314   if (type->code () == TYPE_CODE_TYPEDEF)
2315     type = ada_typedef_target_type (type);
2316
2317   raw_name = ada_type_name (ada_check_typedef (type));
2318   if (!raw_name)
2319     raw_name = ada_type_name (desc_base_type (type));
2320
2321   if (!raw_name)
2322     return 0;
2323
2324   tail = strstr (raw_name, "___XP");
2325   if (tail == nullptr)
2326     {
2327       gdb_assert (is_thick_pntr (type));
2328       /* The structure's first field is a pointer to an array, so this
2329          fetches the array type.  */
2330       type = type->field (0).type ()->target_type ();
2331       /* Now we can see if the array elements are packed.  */
2332       return TYPE_FIELD_BITSIZE (type, 0);
2333     }
2334
2335   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2336     {
2337       lim_warning
2338         (_("could not understand bit size information on packed array"));
2339       return 0;
2340     }
2341
2342   return bits;
2343 }
2344
2345 /* Given that TYPE is a standard GDB array type with all bounds filled
2346    in, and that the element size of its ultimate scalar constituents
2347    (that is, either its elements, or, if it is an array of arrays, its
2348    elements' elements, etc.) is *ELT_BITS, return an identical type,
2349    but with the bit sizes of its elements (and those of any
2350    constituent arrays) recorded in the BITSIZE components of its
2351    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2352    in bits.
2353
2354    Note that, for arrays whose index type has an XA encoding where
2355    a bound references a record discriminant, getting that discriminant,
2356    and therefore the actual value of that bound, is not possible
2357    because none of the given parameters gives us access to the record.
2358    This function assumes that it is OK in the context where it is being
2359    used to return an array whose bounds are still dynamic and where
2360    the length is arbitrary.  */
2361
2362 static struct type *
2363 constrained_packed_array_type (struct type *type, long *elt_bits)
2364 {
2365   struct type *new_elt_type;
2366   struct type *new_type;
2367   struct type *index_type_desc;
2368   struct type *index_type;
2369   LONGEST low_bound, high_bound;
2370
2371   type = ada_check_typedef (type);
2372   if (type->code () != TYPE_CODE_ARRAY)
2373     return type;
2374
2375   index_type_desc = ada_find_parallel_type (type, "___XA");
2376   if (index_type_desc)
2377     index_type = to_fixed_range_type (index_type_desc->field (0).type (),
2378                                       NULL);
2379   else
2380     index_type = type->index_type ();
2381
2382   new_type = alloc_type_copy (type);
2383   new_elt_type =
2384     constrained_packed_array_type (ada_check_typedef (type->target_type ()),
2385                                    elt_bits);
2386   create_array_type (new_type, new_elt_type, index_type);
2387   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2388   new_type->set_name (ada_type_name (type));
2389
2390   if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
2391        && is_dynamic_type (check_typedef (index_type)))
2392       || !get_discrete_bounds (index_type, &low_bound, &high_bound))
2393     low_bound = high_bound = 0;
2394   if (high_bound < low_bound)
2395     {
2396       *elt_bits = 0;
2397       new_type->set_length (0);
2398     }
2399   else
2400     {
2401       *elt_bits *= (high_bound - low_bound + 1);
2402       new_type->set_length ((*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT);
2403     }
2404
2405   new_type->set_is_fixed_instance (true);
2406   return new_type;
2407 }
2408
2409 /* The array type encoded by TYPE, where
2410    ada_is_constrained_packed_array_type (TYPE).  */
2411
2412 static struct type *
2413 decode_constrained_packed_array_type (struct type *type)
2414 {
2415   const char *raw_name = ada_type_name (ada_check_typedef (type));
2416   char *name;
2417   const char *tail;
2418   struct type *shadow_type;
2419   long bits;
2420
2421   if (!raw_name)
2422     raw_name = ada_type_name (desc_base_type (type));
2423
2424   if (!raw_name)
2425     return NULL;
2426
2427   name = (char *) alloca (strlen (raw_name) + 1);
2428   tail = strstr (raw_name, "___XP");
2429   type = desc_base_type (type);
2430
2431   memcpy (name, raw_name, tail - raw_name);
2432   name[tail - raw_name] = '\000';
2433
2434   shadow_type = ada_find_parallel_type_with_name (type, name);
2435
2436   if (shadow_type == NULL)
2437     {
2438       lim_warning (_("could not find bounds information on packed array"));
2439       return NULL;
2440     }
2441   shadow_type = check_typedef (shadow_type);
2442
2443   if (shadow_type->code () != TYPE_CODE_ARRAY)
2444     {
2445       lim_warning (_("could not understand bounds "
2446                      "information on packed array"));
2447       return NULL;
2448     }
2449
2450   bits = decode_packed_array_bitsize (type);
2451   return constrained_packed_array_type (shadow_type, &bits);
2452 }
2453
2454 /* Helper function for decode_constrained_packed_array.  Set the field
2455    bitsize on a series of packed arrays.  Returns the number of
2456    elements in TYPE.  */
2457
2458 static LONGEST
2459 recursively_update_array_bitsize (struct type *type)
2460 {
2461   gdb_assert (type->code () == TYPE_CODE_ARRAY);
2462
2463   LONGEST low, high;
2464   if (!get_discrete_bounds (type->index_type (), &low, &high)
2465       || low > high)
2466     return 0;
2467   LONGEST our_len = high - low + 1;
2468
2469   struct type *elt_type = type->target_type ();
2470   if (elt_type->code () == TYPE_CODE_ARRAY)
2471     {
2472       LONGEST elt_len = recursively_update_array_bitsize (elt_type);
2473       LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
2474       TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
2475
2476       type->set_length (((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
2477                          / HOST_CHAR_BIT));
2478     }
2479
2480   return our_len;
2481 }
2482
2483 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2484    array, returns a simple array that denotes that array.  Its type is a
2485    standard GDB array type except that the BITSIZEs of the array
2486    target types are set to the number of bits in each element, and the
2487    type length is set appropriately.  */
2488
2489 static struct value *
2490 decode_constrained_packed_array (struct value *arr)
2491 {
2492   struct type *type;
2493
2494   /* If our value is a pointer, then dereference it. Likewise if
2495      the value is a reference.  Make sure that this operation does not
2496      cause the target type to be fixed, as this would indirectly cause
2497      this array to be decoded.  The rest of the routine assumes that
2498      the array hasn't been decoded yet, so we use the basic "coerce_ref"
2499      and "value_ind" routines to perform the dereferencing, as opposed
2500      to using "ada_coerce_ref" or "ada_value_ind".  */
2501   arr = coerce_ref (arr);
2502   if (ada_check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2503     arr = value_ind (arr);
2504
2505   type = decode_constrained_packed_array_type (value_type (arr));
2506   if (type == NULL)
2507     {
2508       error (_("can't unpack array"));
2509       return NULL;
2510     }
2511
2512   /* Decoding the packed array type could not correctly set the field
2513      bitsizes for any dimension except the innermost, because the
2514      bounds may be variable and were not passed to that function.  So,
2515      we further resolve the array bounds here and then update the
2516      sizes.  */
2517   const gdb_byte *valaddr = value_contents_for_printing (arr).data ();
2518   CORE_ADDR address = value_address (arr);
2519   gdb::array_view<const gdb_byte> view
2520     = gdb::make_array_view (valaddr, type->length ());
2521   type = resolve_dynamic_type (type, view, address);
2522   recursively_update_array_bitsize (type);
2523
2524   if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2525       && ada_is_modular_type (value_type (arr)))
2526     {
2527        /* This is a (right-justified) modular type representing a packed
2528           array with no wrapper.  In order to interpret the value through
2529           the (left-justified) packed array type we just built, we must
2530           first left-justify it.  */
2531       int bit_size, bit_pos;
2532       ULONGEST mod;
2533
2534       mod = ada_modulus (value_type (arr)) - 1;
2535       bit_size = 0;
2536       while (mod > 0)
2537         {
2538           bit_size += 1;
2539           mod >>= 1;
2540         }
2541       bit_pos = HOST_CHAR_BIT * value_type (arr)->length () - bit_size;
2542       arr = ada_value_primitive_packed_val (arr, NULL,
2543                                             bit_pos / HOST_CHAR_BIT,
2544                                             bit_pos % HOST_CHAR_BIT,
2545                                             bit_size,
2546                                             type);
2547     }
2548
2549   return coerce_unspec_val_to_type (arr, type);
2550 }
2551
2552
2553 /* The value of the element of packed array ARR at the ARITY indices
2554    given in IND.   ARR must be a simple array.  */
2555
2556 static struct value *
2557 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2558 {
2559   int i;
2560   int bits, elt_off, bit_off;
2561   long elt_total_bit_offset;
2562   struct type *elt_type;
2563   struct value *v;
2564
2565   bits = 0;
2566   elt_total_bit_offset = 0;
2567   elt_type = ada_check_typedef (value_type (arr));
2568   for (i = 0; i < arity; i += 1)
2569     {
2570       if (elt_type->code () != TYPE_CODE_ARRAY
2571           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2572         error
2573           (_("attempt to do packed indexing of "
2574              "something other than a packed array"));
2575       else
2576         {
2577           struct type *range_type = elt_type->index_type ();
2578           LONGEST lowerbound, upperbound;
2579           LONGEST idx;
2580
2581           if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
2582             {
2583               lim_warning (_("don't know bounds of array"));
2584               lowerbound = upperbound = 0;
2585             }
2586
2587           idx = pos_atr (ind[i]);
2588           if (idx < lowerbound || idx > upperbound)
2589             lim_warning (_("packed array index %ld out of bounds"),
2590                          (long) idx);
2591           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2592           elt_total_bit_offset += (idx - lowerbound) * bits;
2593           elt_type = ada_check_typedef (elt_type->target_type ());
2594         }
2595     }
2596   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2597   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2598
2599   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2600                                       bits, elt_type);
2601   return v;
2602 }
2603
2604 /* Non-zero iff TYPE includes negative integer values.  */
2605
2606 static int
2607 has_negatives (struct type *type)
2608 {
2609   switch (type->code ())
2610     {
2611     default:
2612       return 0;
2613     case TYPE_CODE_INT:
2614       return !type->is_unsigned ();
2615     case TYPE_CODE_RANGE:
2616       return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
2617     }
2618 }
2619
2620 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2621    unpack that data into UNPACKED.  UNPACKED_LEN is the size in bytes of
2622    the unpacked buffer.
2623
2624    The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2625    enough to contain at least BIT_OFFSET bits.  If not, an error is raised.
2626
2627    IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2628    zero otherwise.
2629
2630    IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2631
2632    IS_SCALAR is nonzero if the data corresponds to a signed type.  */
2633
2634 static void
2635 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2636                           gdb_byte *unpacked, int unpacked_len,
2637                           int is_big_endian, int is_signed_type,
2638                           int is_scalar)
2639 {
2640   int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2641   int src_idx;                  /* Index into the source area */
2642   int src_bytes_left;           /* Number of source bytes left to process.  */
2643   int srcBitsLeft;              /* Number of source bits left to move */
2644   int unusedLS;                 /* Number of bits in next significant
2645                                    byte of source that are unused */
2646
2647   int unpacked_idx;             /* Index into the unpacked buffer */
2648   int unpacked_bytes_left;      /* Number of bytes left to set in unpacked.  */
2649
2650   unsigned long accum;          /* Staging area for bits being transferred */
2651   int accumSize;                /* Number of meaningful bits in accum */
2652   unsigned char sign;
2653
2654   /* Transmit bytes from least to most significant; delta is the direction
2655      the indices move.  */
2656   int delta = is_big_endian ? -1 : 1;
2657
2658   /* Make sure that unpacked is large enough to receive the BIT_SIZE
2659      bits from SRC.  .*/
2660   if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2661     error (_("Cannot unpack %d bits into buffer of %d bytes"),
2662            bit_size, unpacked_len);
2663
2664   srcBitsLeft = bit_size;
2665   src_bytes_left = src_len;
2666   unpacked_bytes_left = unpacked_len;
2667   sign = 0;
2668
2669   if (is_big_endian)
2670     {
2671       src_idx = src_len - 1;
2672       if (is_signed_type
2673           && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2674         sign = ~0;
2675
2676       unusedLS =
2677         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2678         % HOST_CHAR_BIT;
2679
2680       if (is_scalar)
2681         {
2682           accumSize = 0;
2683           unpacked_idx = unpacked_len - 1;
2684         }
2685       else
2686         {
2687           /* Non-scalar values must be aligned at a byte boundary...  */
2688           accumSize =
2689             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2690           /* ... And are placed at the beginning (most-significant) bytes
2691              of the target.  */
2692           unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2693           unpacked_bytes_left = unpacked_idx + 1;
2694         }
2695     }
2696   else
2697     {
2698       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2699
2700       src_idx = unpacked_idx = 0;
2701       unusedLS = bit_offset;
2702       accumSize = 0;
2703
2704       if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2705         sign = ~0;
2706     }
2707
2708   accum = 0;
2709   while (src_bytes_left > 0)
2710     {
2711       /* Mask for removing bits of the next source byte that are not
2712          part of the value.  */
2713       unsigned int unusedMSMask =
2714         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2715         1;
2716       /* Sign-extend bits for this byte.  */
2717       unsigned int signMask = sign & ~unusedMSMask;
2718
2719       accum |=
2720         (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2721       accumSize += HOST_CHAR_BIT - unusedLS;
2722       if (accumSize >= HOST_CHAR_BIT)
2723         {
2724           unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2725           accumSize -= HOST_CHAR_BIT;
2726           accum >>= HOST_CHAR_BIT;
2727           unpacked_bytes_left -= 1;
2728           unpacked_idx += delta;
2729         }
2730       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2731       unusedLS = 0;
2732       src_bytes_left -= 1;
2733       src_idx += delta;
2734     }
2735   while (unpacked_bytes_left > 0)
2736     {
2737       accum |= sign << accumSize;
2738       unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2739       accumSize -= HOST_CHAR_BIT;
2740       if (accumSize < 0)
2741         accumSize = 0;
2742       accum >>= HOST_CHAR_BIT;
2743       unpacked_bytes_left -= 1;
2744       unpacked_idx += delta;
2745     }
2746 }
2747
2748 /* Create a new value of type TYPE from the contents of OBJ starting
2749    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2750    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2751    assigning through the result will set the field fetched from.
2752    VALADDR is ignored unless OBJ is NULL, in which case,
2753    VALADDR+OFFSET must address the start of storage containing the 
2754    packed value.  The value returned  in this case is never an lval.
2755    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2756
2757 struct value *
2758 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2759                                 long offset, int bit_offset, int bit_size,
2760                                 struct type *type)
2761 {
2762   struct value *v;
2763   const gdb_byte *src;                /* First byte containing data to unpack */
2764   gdb_byte *unpacked;
2765   const int is_scalar = is_scalar_type (type);
2766   const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2767   gdb::byte_vector staging;
2768
2769   type = ada_check_typedef (type);
2770
2771   if (obj == NULL)
2772     src = valaddr + offset;
2773   else
2774     src = value_contents (obj).data () + offset;
2775
2776   if (is_dynamic_type (type))
2777     {
2778       /* The length of TYPE might by dynamic, so we need to resolve
2779          TYPE in order to know its actual size, which we then use
2780          to create the contents buffer of the value we return.
2781          The difficulty is that the data containing our object is
2782          packed, and therefore maybe not at a byte boundary.  So, what
2783          we do, is unpack the data into a byte-aligned buffer, and then
2784          use that buffer as our object's value for resolving the type.  */
2785       int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2786       staging.resize (staging_len);
2787
2788       ada_unpack_from_contents (src, bit_offset, bit_size,
2789                                 staging.data (), staging.size (),
2790                                 is_big_endian, has_negatives (type),
2791                                 is_scalar);
2792       type = resolve_dynamic_type (type, staging, 0);
2793       if (type->length () < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2794         {
2795           /* This happens when the length of the object is dynamic,
2796              and is actually smaller than the space reserved for it.
2797              For instance, in an array of variant records, the bit_size
2798              we're given is the array stride, which is constant and
2799              normally equal to the maximum size of its element.
2800              But, in reality, each element only actually spans a portion
2801              of that stride.  */
2802           bit_size = type->length () * HOST_CHAR_BIT;
2803         }
2804     }
2805
2806   if (obj == NULL)
2807     {
2808       v = allocate_value (type);
2809       src = valaddr + offset;
2810     }
2811   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2812     {
2813       int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2814       gdb_byte *buf;
2815
2816       v = value_at (type, value_address (obj) + offset);
2817       buf = (gdb_byte *) alloca (src_len);
2818       read_memory (value_address (v), buf, src_len);
2819       src = buf;
2820     }
2821   else
2822     {
2823       v = allocate_value (type);
2824       src = value_contents (obj).data () + offset;
2825     }
2826
2827   if (obj != NULL)
2828     {
2829       long new_offset = offset;
2830
2831       set_value_component_location (v, obj);
2832       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2833       set_value_bitsize (v, bit_size);
2834       if (value_bitpos (v) >= HOST_CHAR_BIT)
2835         {
2836           ++new_offset;
2837           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2838         }
2839       set_value_offset (v, new_offset);
2840
2841       /* Also set the parent value.  This is needed when trying to
2842          assign a new value (in inferior memory).  */
2843       set_value_parent (v, obj);
2844     }
2845   else
2846     set_value_bitsize (v, bit_size);
2847   unpacked = value_contents_writeable (v).data ();
2848
2849   if (bit_size == 0)
2850     {
2851       memset (unpacked, 0, type->length ());
2852       return v;
2853     }
2854
2855   if (staging.size () == type->length ())
2856     {
2857       /* Small short-cut: If we've unpacked the data into a buffer
2858          of the same size as TYPE's length, then we can reuse that,
2859          instead of doing the unpacking again.  */
2860       memcpy (unpacked, staging.data (), staging.size ());
2861     }
2862   else
2863     ada_unpack_from_contents (src, bit_offset, bit_size,
2864                               unpacked, type->length (),
2865                               is_big_endian, has_negatives (type), is_scalar);
2866
2867   return v;
2868 }
2869
2870 /* Store the contents of FROMVAL into the location of TOVAL.
2871    Return a new value with the location of TOVAL and contents of
2872    FROMVAL.   Handles assignment into packed fields that have
2873    floating-point or non-scalar types.  */
2874
2875 static struct value *
2876 ada_value_assign (struct value *toval, struct value *fromval)
2877 {
2878   struct type *type = value_type (toval);
2879   int bits = value_bitsize (toval);
2880
2881   toval = ada_coerce_ref (toval);
2882   fromval = ada_coerce_ref (fromval);
2883
2884   if (ada_is_direct_array_type (value_type (toval)))
2885     toval = ada_coerce_to_simple_array (toval);
2886   if (ada_is_direct_array_type (value_type (fromval)))
2887     fromval = ada_coerce_to_simple_array (fromval);
2888
2889   if (!deprecated_value_modifiable (toval))
2890     error (_("Left operand of assignment is not a modifiable lvalue."));
2891
2892   if (VALUE_LVAL (toval) == lval_memory
2893       && bits > 0
2894       && (type->code () == TYPE_CODE_FLT
2895           || type->code () == TYPE_CODE_STRUCT))
2896     {
2897       int len = (value_bitpos (toval)
2898                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2899       int from_size;
2900       gdb_byte *buffer = (gdb_byte *) alloca (len);
2901       struct value *val;
2902       CORE_ADDR to_addr = value_address (toval);
2903
2904       if (type->code () == TYPE_CODE_FLT)
2905         fromval = value_cast (type, fromval);
2906
2907       read_memory (to_addr, buffer, len);
2908       from_size = value_bitsize (fromval);
2909       if (from_size == 0)
2910         from_size = value_type (fromval)->length () * TARGET_CHAR_BIT;
2911
2912       const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2913       ULONGEST from_offset = 0;
2914       if (is_big_endian && is_scalar_type (value_type (fromval)))
2915         from_offset = from_size - bits;
2916       copy_bitwise (buffer, value_bitpos (toval),
2917                     value_contents (fromval).data (), from_offset,
2918                     bits, is_big_endian);
2919       write_memory_with_notification (to_addr, buffer, len);
2920
2921       val = value_copy (toval);
2922       memcpy (value_contents_raw (val).data (),
2923               value_contents (fromval).data (),
2924               type->length ());
2925       deprecated_set_value_type (val, type);
2926
2927       return val;
2928     }
2929
2930   return value_assign (toval, fromval);
2931 }
2932
2933
2934 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2935    CONTAINER, assign the contents of VAL to COMPONENTS's place in
2936    CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
2937    COMPONENT, and not the inferior's memory.  The current contents
2938    of COMPONENT are ignored.
2939
2940    Although not part of the initial design, this function also works
2941    when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2942    had a null address, and COMPONENT had an address which is equal to
2943    its offset inside CONTAINER.  */
2944
2945 static void
2946 value_assign_to_component (struct value *container, struct value *component,
2947                            struct value *val)
2948 {
2949   LONGEST offset_in_container =
2950     (LONGEST)  (value_address (component) - value_address (container));
2951   int bit_offset_in_container =
2952     value_bitpos (component) - value_bitpos (container);
2953   int bits;
2954
2955   val = value_cast (value_type (component), val);
2956
2957   if (value_bitsize (component) == 0)
2958     bits = TARGET_CHAR_BIT * value_type (component)->length ();
2959   else
2960     bits = value_bitsize (component);
2961
2962   if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2963     {
2964       int src_offset;
2965
2966       if (is_scalar_type (check_typedef (value_type (component))))
2967         src_offset
2968           = value_type (component)->length () * TARGET_CHAR_BIT - bits;
2969       else
2970         src_offset = 0;
2971       copy_bitwise ((value_contents_writeable (container).data ()
2972                      + offset_in_container),
2973                     value_bitpos (container) + bit_offset_in_container,
2974                     value_contents (val).data (), src_offset, bits, 1);
2975     }
2976   else
2977     copy_bitwise ((value_contents_writeable (container).data ()
2978                    + offset_in_container),
2979                   value_bitpos (container) + bit_offset_in_container,
2980                   value_contents (val).data (), 0, bits, 0);
2981 }
2982
2983 /* Determine if TYPE is an access to an unconstrained array.  */
2984
2985 bool
2986 ada_is_access_to_unconstrained_array (struct type *type)
2987 {
2988   return (type->code () == TYPE_CODE_TYPEDEF
2989           && is_thick_pntr (ada_typedef_target_type (type)));
2990 }
2991
2992 /* The value of the element of array ARR at the ARITY indices given in IND.
2993    ARR may be either a simple array, GNAT array descriptor, or pointer
2994    thereto.  */
2995
2996 struct value *
2997 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2998 {
2999   int k;
3000   struct value *elt;
3001   struct type *elt_type;
3002
3003   elt = ada_coerce_to_simple_array (arr);
3004
3005   elt_type = ada_check_typedef (value_type (elt));
3006   if (elt_type->code () == TYPE_CODE_ARRAY
3007       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
3008     return value_subscript_packed (elt, arity, ind);
3009
3010   for (k = 0; k < arity; k += 1)
3011     {
3012       struct type *saved_elt_type = elt_type->target_type ();
3013
3014       if (elt_type->code () != TYPE_CODE_ARRAY)
3015         error (_("too many subscripts (%d expected)"), k);
3016
3017       elt = value_subscript (elt, pos_atr (ind[k]));
3018
3019       if (ada_is_access_to_unconstrained_array (saved_elt_type)
3020           && value_type (elt)->code () != TYPE_CODE_TYPEDEF)
3021         {
3022           /* The element is a typedef to an unconstrained array,
3023              except that the value_subscript call stripped the
3024              typedef layer.  The typedef layer is GNAT's way to
3025              specify that the element is, at the source level, an
3026              access to the unconstrained array, rather than the
3027              unconstrained array.  So, we need to restore that
3028              typedef layer, which we can do by forcing the element's
3029              type back to its original type. Otherwise, the returned
3030              value is going to be printed as the array, rather
3031              than as an access.  Another symptom of the same issue
3032              would be that an expression trying to dereference the
3033              element would also be improperly rejected.  */
3034           deprecated_set_value_type (elt, saved_elt_type);
3035         }
3036
3037       elt_type = ada_check_typedef (value_type (elt));
3038     }
3039
3040   return elt;
3041 }
3042
3043 /* Assuming ARR is a pointer to a GDB array, the value of the element
3044    of *ARR at the ARITY indices given in IND.
3045    Does not read the entire array into memory.
3046
3047    Note: Unlike what one would expect, this function is used instead of
3048    ada_value_subscript for basically all non-packed array types.  The reason
3049    for this is that a side effect of doing our own pointer arithmetics instead
3050    of relying on value_subscript is that there is no implicit typedef peeling.
3051    This is important for arrays of array accesses, where it allows us to
3052    preserve the fact that the array's element is an array access, where the
3053    access part os encoded in a typedef layer.  */
3054
3055 static struct value *
3056 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
3057 {
3058   int k;
3059   struct value *array_ind = ada_value_ind (arr);
3060   struct type *type
3061     = check_typedef (value_enclosing_type (array_ind));
3062
3063   if (type->code () == TYPE_CODE_ARRAY
3064       && TYPE_FIELD_BITSIZE (type, 0) > 0)
3065     return value_subscript_packed (array_ind, arity, ind);
3066
3067   for (k = 0; k < arity; k += 1)
3068     {
3069       LONGEST lwb, upb;
3070
3071       if (type->code () != TYPE_CODE_ARRAY)
3072         error (_("too many subscripts (%d expected)"), k);
3073       arr = value_cast (lookup_pointer_type (type->target_type ()),
3074                         value_copy (arr));
3075       get_discrete_bounds (type->index_type (), &lwb, &upb);
3076       arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
3077       type = type->target_type ();
3078     }
3079
3080   return value_ind (arr);
3081 }
3082
3083 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
3084    actual type of ARRAY_PTR is ignored), returns the Ada slice of
3085    HIGH'Pos-LOW'Pos+1 elements starting at index LOW.  The lower bound of
3086    this array is LOW, as per Ada rules.  */
3087 static struct value *
3088 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
3089                           int low, int high)
3090 {
3091   struct type *type0 = ada_check_typedef (type);
3092   struct type *base_index_type = type0->index_type ()->target_type ();
3093   struct type *index_type
3094     = create_static_range_type (NULL, base_index_type, low, high);
3095   struct type *slice_type = create_array_type_with_stride
3096                               (NULL, type0->target_type (), index_type,
3097                                type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
3098                                TYPE_FIELD_BITSIZE (type0, 0));
3099   int base_low =  ada_discrete_type_low_bound (type0->index_type ());
3100   gdb::optional<LONGEST> base_low_pos, low_pos;
3101   CORE_ADDR base;
3102
3103   low_pos = discrete_position (base_index_type, low);
3104   base_low_pos = discrete_position (base_index_type, base_low);
3105
3106   if (!low_pos.has_value () || !base_low_pos.has_value ())
3107     {
3108       warning (_("unable to get positions in slice, use bounds instead"));
3109       low_pos = low;
3110       base_low_pos = base_low;
3111     }
3112
3113   ULONGEST stride = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
3114   if (stride == 0)
3115     stride = type0->target_type ()->length ();
3116
3117   base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
3118   return value_at_lazy (slice_type, base);
3119 }
3120
3121
3122 static struct value *
3123 ada_value_slice (struct value *array, int low, int high)
3124 {
3125   struct type *type = ada_check_typedef (value_type (array));
3126   struct type *base_index_type = type->index_type ()->target_type ();
3127   struct type *index_type
3128     = create_static_range_type (NULL, type->index_type (), low, high);
3129   struct type *slice_type = create_array_type_with_stride
3130                               (NULL, type->target_type (), index_type,
3131                                type->dyn_prop (DYN_PROP_BYTE_STRIDE),
3132                                TYPE_FIELD_BITSIZE (type, 0));
3133   gdb::optional<LONGEST> low_pos, high_pos;
3134
3135
3136   low_pos = discrete_position (base_index_type, low);
3137   high_pos = discrete_position (base_index_type, high);
3138
3139   if (!low_pos.has_value () || !high_pos.has_value ())
3140     {
3141       warning (_("unable to get positions in slice, use bounds instead"));
3142       low_pos = low;
3143       high_pos = high;
3144     }
3145
3146   return value_cast (slice_type,
3147                      value_slice (array, low, *high_pos - *low_pos + 1));
3148 }
3149
3150 /* If type is a record type in the form of a standard GNAT array
3151    descriptor, returns the number of dimensions for type.  If arr is a
3152    simple array, returns the number of "array of"s that prefix its
3153    type designation.  Otherwise, returns 0.  */
3154
3155 int
3156 ada_array_arity (struct type *type)
3157 {
3158   int arity;
3159
3160   if (type == NULL)
3161     return 0;
3162
3163   type = desc_base_type (type);
3164
3165   arity = 0;
3166   if (type->code () == TYPE_CODE_STRUCT)
3167     return desc_arity (desc_bounds_type (type));
3168   else
3169     while (type->code () == TYPE_CODE_ARRAY)
3170       {
3171         arity += 1;
3172         type = ada_check_typedef (type->target_type ());
3173       }
3174
3175   return arity;
3176 }
3177
3178 /* If TYPE is a record type in the form of a standard GNAT array
3179    descriptor or a simple array type, returns the element type for
3180    TYPE after indexing by NINDICES indices, or by all indices if
3181    NINDICES is -1.  Otherwise, returns NULL.  */
3182
3183 struct type *
3184 ada_array_element_type (struct type *type, int nindices)
3185 {
3186   type = desc_base_type (type);
3187
3188   if (type->code () == TYPE_CODE_STRUCT)
3189     {
3190       int k;
3191       struct type *p_array_type;
3192
3193       p_array_type = desc_data_target_type (type);
3194
3195       k = ada_array_arity (type);
3196       if (k == 0)
3197         return NULL;
3198
3199       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
3200       if (nindices >= 0 && k > nindices)
3201         k = nindices;
3202       while (k > 0 && p_array_type != NULL)
3203         {
3204           p_array_type = ada_check_typedef (p_array_type->target_type ());
3205           k -= 1;
3206         }
3207       return p_array_type;
3208     }
3209   else if (type->code () == TYPE_CODE_ARRAY)
3210     {
3211       while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
3212         {
3213           type = type->target_type ();
3214           /* A multi-dimensional array is represented using a sequence
3215              of array types.  If one of these types has a name, then
3216              it is not another dimension of the outer array, but
3217              rather the element type of the outermost array.  */
3218           if (type->name () != nullptr)
3219             break;
3220           nindices -= 1;
3221         }
3222       return type;
3223     }
3224
3225   return NULL;
3226 }
3227
3228 /* See ada-lang.h.  */
3229
3230 struct type *
3231 ada_index_type (struct type *type, int n, const char *name)
3232 {
3233   struct type *result_type;
3234
3235   type = desc_base_type (type);
3236
3237   if (n < 0 || n > ada_array_arity (type))
3238     error (_("invalid dimension number to '%s"), name);
3239
3240   if (ada_is_simple_array_type (type))
3241     {
3242       int i;
3243
3244       for (i = 1; i < n; i += 1)
3245         {
3246           type = ada_check_typedef (type);
3247           type = type->target_type ();
3248         }
3249       result_type = ada_check_typedef (type)->index_type ()->target_type ();
3250       /* FIXME: The stabs type r(0,0);bound;bound in an array type
3251          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
3252          perhaps stabsread.c would make more sense.  */
3253       if (result_type && result_type->code () == TYPE_CODE_UNDEF)
3254         result_type = NULL;
3255     }
3256   else
3257     {
3258       result_type = desc_index_type (desc_bounds_type (type), n);
3259       if (result_type == NULL)
3260         error (_("attempt to take bound of something that is not an array"));
3261     }
3262
3263   return result_type;
3264 }
3265
3266 /* Given that arr is an array type, returns the lower bound of the
3267    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3268    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
3269    array-descriptor type.  It works for other arrays with bounds supplied
3270    by run-time quantities other than discriminants.  */
3271
3272 static LONGEST
3273 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3274 {
3275   struct type *type, *index_type_desc, *index_type;
3276   int i;
3277
3278   gdb_assert (which == 0 || which == 1);
3279
3280   if (ada_is_constrained_packed_array_type (arr_type))
3281     arr_type = decode_constrained_packed_array_type (arr_type);
3282
3283   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3284     return (LONGEST) - which;
3285
3286   if (arr_type->code () == TYPE_CODE_PTR)
3287     type = arr_type->target_type ();
3288   else
3289     type = arr_type;
3290
3291   if (type->is_fixed_instance ())
3292     {
3293       /* The array has already been fixed, so we do not need to
3294          check the parallel ___XA type again.  That encoding has
3295          already been applied, so ignore it now.  */
3296       index_type_desc = NULL;
3297     }
3298   else
3299     {
3300       index_type_desc = ada_find_parallel_type (type, "___XA");
3301       ada_fixup_array_indexes_type (index_type_desc);
3302     }
3303
3304   if (index_type_desc != NULL)
3305     index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
3306                                       NULL);
3307   else
3308     {
3309       struct type *elt_type = check_typedef (type);
3310
3311       for (i = 1; i < n; i++)
3312         elt_type = check_typedef (elt_type->target_type ());
3313
3314       index_type = elt_type->index_type ();
3315     }
3316
3317   return
3318     (LONGEST) (which == 0
3319                ? ada_discrete_type_low_bound (index_type)
3320                : ada_discrete_type_high_bound (index_type));
3321 }
3322
3323 /* Given that arr is an array value, returns the lower bound of the
3324    nth index (numbering from 1) if WHICH is 0, and the upper bound if
3325    WHICH is 1.  This routine will also work for arrays with bounds
3326    supplied by run-time quantities other than discriminants.  */
3327
3328 static LONGEST
3329 ada_array_bound (struct value *arr, int n, int which)
3330 {
3331   struct type *arr_type;
3332
3333   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3334     arr = value_ind (arr);
3335   arr_type = value_enclosing_type (arr);
3336
3337   if (ada_is_constrained_packed_array_type (arr_type))
3338     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3339   else if (ada_is_simple_array_type (arr_type))
3340     return ada_array_bound_from_type (arr_type, n, which);
3341   else
3342     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3343 }
3344
3345 /* Given that arr is an array value, returns the length of the
3346    nth index.  This routine will also work for arrays with bounds
3347    supplied by run-time quantities other than discriminants.
3348    Does not work for arrays indexed by enumeration types with representation
3349    clauses at the moment.  */
3350
3351 static LONGEST
3352 ada_array_length (struct value *arr, int n)
3353 {
3354   struct type *arr_type, *index_type;
3355   int low, high;
3356
3357   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3358     arr = value_ind (arr);
3359   arr_type = value_enclosing_type (arr);
3360
3361   if (ada_is_constrained_packed_array_type (arr_type))
3362     return ada_array_length (decode_constrained_packed_array (arr), n);
3363
3364   if (ada_is_simple_array_type (arr_type))
3365     {
3366       low = ada_array_bound_from_type (arr_type, n, 0);
3367       high = ada_array_bound_from_type (arr_type, n, 1);
3368     }
3369   else
3370     {
3371       low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3372       high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3373     }
3374
3375   arr_type = check_typedef (arr_type);
3376   index_type = ada_index_type (arr_type, n, "length");
3377   if (index_type != NULL)
3378     {
3379       struct type *base_type;
3380       if (index_type->code () == TYPE_CODE_RANGE)
3381         base_type = index_type->target_type ();
3382       else
3383         base_type = index_type;
3384
3385       low = pos_atr (value_from_longest (base_type, low));
3386       high = pos_atr (value_from_longest (base_type, high));
3387     }
3388   return high - low + 1;
3389 }
3390
3391 /* An array whose type is that of ARR_TYPE (an array type), with
3392    bounds LOW to HIGH, but whose contents are unimportant.  If HIGH is
3393    less than LOW, then LOW-1 is used.  */
3394
3395 static struct value *
3396 empty_array (struct type *arr_type, int low, int high)
3397 {
3398   struct type *arr_type0 = ada_check_typedef (arr_type);
3399   struct type *index_type
3400     = create_static_range_type
3401         (NULL, arr_type0->index_type ()->target_type (), low,
3402          high < low ? low - 1 : high);
3403   struct type *elt_type = ada_array_element_type (arr_type0, 1);
3404
3405   return allocate_value (create_array_type (NULL, elt_type, index_type));
3406 }
3407 \f
3408
3409                                 /* Name resolution */
3410
3411 /* The "decoded" name for the user-definable Ada operator corresponding
3412    to OP.  */
3413
3414 static const char *
3415 ada_decoded_op_name (enum exp_opcode op)
3416 {
3417   int i;
3418
3419   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3420     {
3421       if (ada_opname_table[i].op == op)
3422         return ada_opname_table[i].decoded;
3423     }
3424   error (_("Could not find operator name for opcode"));
3425 }
3426
3427 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3428    in a listing of choices during disambiguation (see sort_choices, below).
3429    The idea is that overloadings of a subprogram name from the
3430    same package should sort in their source order.  We settle for ordering
3431    such symbols by their trailing number (__N  or $N).  */
3432
3433 static int
3434 encoded_ordered_before (const char *N0, const char *N1)
3435 {
3436   if (N1 == NULL)
3437     return 0;
3438   else if (N0 == NULL)
3439     return 1;
3440   else
3441     {
3442       int k0, k1;
3443
3444       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3445         ;
3446       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3447         ;
3448       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3449           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3450         {
3451           int n0, n1;
3452
3453           n0 = k0;
3454           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3455             n0 -= 1;
3456           n1 = k1;
3457           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3458             n1 -= 1;
3459           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3460             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3461         }
3462       return (strcmp (N0, N1) < 0);
3463     }
3464 }
3465
3466 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3467    encoded names.  */
3468
3469 static void
3470 sort_choices (struct block_symbol syms[], int nsyms)
3471 {
3472   int i;
3473
3474   for (i = 1; i < nsyms; i += 1)
3475     {
3476       struct block_symbol sym = syms[i];
3477       int j;
3478
3479       for (j = i - 1; j >= 0; j -= 1)
3480         {
3481           if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3482                                       sym.symbol->linkage_name ()))
3483             break;
3484           syms[j + 1] = syms[j];
3485         }
3486       syms[j + 1] = sym;
3487     }
3488 }
3489
3490 /* Whether GDB should display formals and return types for functions in the
3491    overloads selection menu.  */
3492 static bool print_signatures = true;
3493
3494 /* Print the signature for SYM on STREAM according to the FLAGS options.  For
3495    all but functions, the signature is just the name of the symbol.  For
3496    functions, this is the name of the function, the list of types for formals
3497    and the return type (if any).  */
3498
3499 static void
3500 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3501                             const struct type_print_options *flags)
3502 {
3503   struct type *type = sym->type ();
3504
3505   gdb_printf (stream, "%s", sym->print_name ());
3506   if (!print_signatures
3507       || type == NULL
3508       || type->code () != TYPE_CODE_FUNC)
3509     return;
3510
3511   if (type->num_fields () > 0)
3512     {
3513       int i;
3514
3515       gdb_printf (stream, " (");
3516       for (i = 0; i < type->num_fields (); ++i)
3517         {
3518           if (i > 0)
3519             gdb_printf (stream, "; ");
3520           ada_print_type (type->field (i).type (), NULL, stream, -1, 0,
3521                           flags);
3522         }
3523       gdb_printf (stream, ")");
3524     }
3525   if (type->target_type () != NULL
3526       && type->target_type ()->code () != TYPE_CODE_VOID)
3527     {
3528       gdb_printf (stream, " return ");
3529       ada_print_type (type->target_type (), NULL, stream, -1, 0, flags);
3530     }
3531 }
3532
3533 /* Read and validate a set of numeric choices from the user in the
3534    range 0 .. N_CHOICES-1.  Place the results in increasing
3535    order in CHOICES[0 .. N-1], and return N.
3536
3537    The user types choices as a sequence of numbers on one line
3538    separated by blanks, encoding them as follows:
3539
3540      + A choice of 0 means to cancel the selection, throwing an error.
3541      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3542      + The user chooses k by typing k+IS_ALL_CHOICE+1.
3543
3544    The user is not allowed to choose more than MAX_RESULTS values.
3545
3546    ANNOTATION_SUFFIX, if present, is used to annotate the input
3547    prompts (for use with the -f switch).  */
3548
3549 static int
3550 get_selections (int *choices, int n_choices, int max_results,
3551                 int is_all_choice, const char *annotation_suffix)
3552 {
3553   const char *args;
3554   const char *prompt;
3555   int n_chosen;
3556   int first_choice = is_all_choice ? 2 : 1;
3557
3558   prompt = getenv ("PS2");
3559   if (prompt == NULL)
3560     prompt = "> ";
3561
3562   args = command_line_input (prompt, annotation_suffix);
3563
3564   if (args == NULL)
3565     error_no_arg (_("one or more choice numbers"));
3566
3567   n_chosen = 0;
3568
3569   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3570      order, as given in args.  Choices are validated.  */
3571   while (1)
3572     {
3573       char *args2;
3574       int choice, j;
3575
3576       args = skip_spaces (args);
3577       if (*args == '\0' && n_chosen == 0)
3578         error_no_arg (_("one or more choice numbers"));
3579       else if (*args == '\0')
3580         break;
3581
3582       choice = strtol (args, &args2, 10);
3583       if (args == args2 || choice < 0
3584           || choice > n_choices + first_choice - 1)
3585         error (_("Argument must be choice number"));
3586       args = args2;
3587
3588       if (choice == 0)
3589         error (_("cancelled"));
3590
3591       if (choice < first_choice)
3592         {
3593           n_chosen = n_choices;
3594           for (j = 0; j < n_choices; j += 1)
3595             choices[j] = j;
3596           break;
3597         }
3598       choice -= first_choice;
3599
3600       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3601         {
3602         }
3603
3604       if (j < 0 || choice != choices[j])
3605         {
3606           int k;
3607
3608           for (k = n_chosen - 1; k > j; k -= 1)
3609             choices[k + 1] = choices[k];
3610           choices[j + 1] = choice;
3611           n_chosen += 1;
3612         }
3613     }
3614
3615   if (n_chosen > max_results)
3616     error (_("Select no more than %d of the above"), max_results);
3617
3618   return n_chosen;
3619 }
3620
3621 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3622    by asking the user (if necessary), returning the number selected,
3623    and setting the first elements of SYMS items.  Error if no symbols
3624    selected.  */
3625
3626 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3627    to be re-integrated one of these days.  */
3628
3629 static int
3630 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3631 {
3632   int i;
3633   int *chosen = XALLOCAVEC (int , nsyms);
3634   int n_chosen;
3635   int first_choice = (max_results == 1) ? 1 : 2;
3636   const char *select_mode = multiple_symbols_select_mode ();
3637
3638   if (max_results < 1)
3639     error (_("Request to select 0 symbols!"));
3640   if (nsyms <= 1)
3641     return nsyms;
3642
3643   if (select_mode == multiple_symbols_cancel)
3644     error (_("\
3645 canceled because the command is ambiguous\n\
3646 See set/show multiple-symbol."));
3647
3648   /* If select_mode is "all", then return all possible symbols.
3649      Only do that if more than one symbol can be selected, of course.
3650      Otherwise, display the menu as usual.  */
3651   if (select_mode == multiple_symbols_all && max_results > 1)
3652     return nsyms;
3653
3654   gdb_printf (_("[0] cancel\n"));
3655   if (max_results > 1)
3656     gdb_printf (_("[1] all\n"));
3657
3658   sort_choices (syms, nsyms);
3659
3660   for (i = 0; i < nsyms; i += 1)
3661     {
3662       if (syms[i].symbol == NULL)
3663         continue;
3664
3665       if (syms[i].symbol->aclass () == LOC_BLOCK)
3666         {
3667           struct symtab_and_line sal =
3668             find_function_start_sal (syms[i].symbol, 1);
3669
3670           gdb_printf ("[%d] ", i + first_choice);
3671           ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3672                                       &type_print_raw_options);
3673           if (sal.symtab == NULL)
3674             gdb_printf (_(" at %p[<no source file available>%p]:%d\n"),
3675                         metadata_style.style ().ptr (), nullptr, sal.line);
3676           else
3677             gdb_printf
3678               (_(" at %ps:%d\n"),
3679                styled_string (file_name_style.style (),
3680                               symtab_to_filename_for_display (sal.symtab)),
3681                sal.line);
3682           continue;
3683         }
3684       else
3685         {
3686           int is_enumeral =
3687             (syms[i].symbol->aclass () == LOC_CONST
3688              && syms[i].symbol->type () != NULL
3689              && syms[i].symbol->type ()->code () == TYPE_CODE_ENUM);
3690           struct symtab *symtab = NULL;
3691
3692           if (syms[i].symbol->is_objfile_owned ())
3693             symtab = syms[i].symbol->symtab ();
3694
3695           if (syms[i].symbol->line () != 0 && symtab != NULL)
3696             {
3697               gdb_printf ("[%d] ", i + first_choice);
3698               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3699                                           &type_print_raw_options);
3700               gdb_printf (_(" at %s:%d\n"),
3701                           symtab_to_filename_for_display (symtab),
3702                           syms[i].symbol->line ());
3703             }
3704           else if (is_enumeral
3705                    && syms[i].symbol->type ()->name () != NULL)
3706             {
3707               gdb_printf (("[%d] "), i + first_choice);
3708               ada_print_type (syms[i].symbol->type (), NULL,
3709                               gdb_stdout, -1, 0, &type_print_raw_options);
3710               gdb_printf (_("'(%s) (enumeral)\n"),
3711                           syms[i].symbol->print_name ());
3712             }
3713           else
3714             {
3715               gdb_printf ("[%d] ", i + first_choice);
3716               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3717                                           &type_print_raw_options);
3718
3719               if (symtab != NULL)
3720                 gdb_printf (is_enumeral
3721                             ? _(" in %s (enumeral)\n")
3722                             : _(" at %s:?\n"),
3723                             symtab_to_filename_for_display (symtab));
3724               else
3725                 gdb_printf (is_enumeral
3726                             ? _(" (enumeral)\n")
3727                             : _(" at ?\n"));
3728             }
3729         }
3730     }
3731
3732   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3733                              "overload-choice");
3734
3735   for (i = 0; i < n_chosen; i += 1)
3736     syms[i] = syms[chosen[i]];
3737
3738   return n_chosen;
3739 }
3740
3741 /* See ada-lang.h.  */
3742
3743 block_symbol
3744 ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
3745                           int nargs, value *argvec[])
3746 {
3747   if (possible_user_operator_p (op, argvec))
3748     {
3749       std::vector<struct block_symbol> candidates
3750         = ada_lookup_symbol_list (ada_decoded_op_name (op),
3751                                   NULL, VAR_DOMAIN);
3752
3753       int i = ada_resolve_function (candidates, argvec,
3754                                     nargs, ada_decoded_op_name (op), NULL,
3755                                     parse_completion);
3756       if (i >= 0)
3757         return candidates[i];
3758     }
3759   return {};
3760 }
3761
3762 /* See ada-lang.h.  */
3763
3764 block_symbol
3765 ada_resolve_funcall (struct symbol *sym, const struct block *block,
3766                      struct type *context_type,
3767                      bool parse_completion,
3768                      int nargs, value *argvec[],
3769                      innermost_block_tracker *tracker)
3770 {
3771   std::vector<struct block_symbol> candidates
3772     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3773
3774   int i;
3775   if (candidates.size () == 1)
3776     i = 0;
3777   else
3778     {
3779       i = ada_resolve_function
3780         (candidates,
3781          argvec, nargs,
3782          sym->linkage_name (),
3783          context_type, parse_completion);
3784       if (i < 0)
3785         error (_("Could not find a match for %s"), sym->print_name ());
3786     }
3787
3788   tracker->update (candidates[i]);
3789   return candidates[i];
3790 }
3791
3792 /* Resolve a mention of a name where the context type is an
3793    enumeration type.  */
3794
3795 static int
3796 ada_resolve_enum (std::vector<struct block_symbol> &syms,
3797                   const char *name, struct type *context_type,
3798                   bool parse_completion)
3799 {
3800   gdb_assert (context_type->code () == TYPE_CODE_ENUM);
3801   context_type = ada_check_typedef (context_type);
3802
3803   for (int i = 0; i < syms.size (); ++i)
3804     {
3805       /* We already know the name matches, so we're just looking for
3806          an element of the correct enum type.  */
3807       if (ada_check_typedef (syms[i].symbol->type ()) == context_type)
3808         return i;
3809     }
3810
3811   error (_("No name '%s' in enumeration type '%s'"), name,
3812          ada_type_name (context_type));
3813 }
3814
3815 /* See ada-lang.h.  */
3816
3817 block_symbol
3818 ada_resolve_variable (struct symbol *sym, const struct block *block,
3819                       struct type *context_type,
3820                       bool parse_completion,
3821                       int deprocedure_p,
3822                       innermost_block_tracker *tracker)
3823 {
3824   std::vector<struct block_symbol> candidates
3825     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3826
3827   if (std::any_of (candidates.begin (),
3828                    candidates.end (),
3829                    [] (block_symbol &bsym)
3830                    {
3831                      switch (bsym.symbol->aclass ())
3832                        {
3833                        case LOC_REGISTER:
3834                        case LOC_ARG:
3835                        case LOC_REF_ARG:
3836                        case LOC_REGPARM_ADDR:
3837                        case LOC_LOCAL:
3838                        case LOC_COMPUTED:
3839                          return true;
3840                        default:
3841                          return false;
3842                        }
3843                    }))
3844     {
3845       /* Types tend to get re-introduced locally, so if there
3846          are any local symbols that are not types, first filter
3847          out all types.  */
3848       candidates.erase
3849         (std::remove_if
3850          (candidates.begin (),
3851           candidates.end (),
3852           [] (block_symbol &bsym)
3853           {
3854             return bsym.symbol->aclass () == LOC_TYPEDEF;
3855           }),
3856          candidates.end ());
3857     }
3858
3859   /* Filter out artificial symbols.  */
3860   candidates.erase
3861     (std::remove_if
3862      (candidates.begin (),
3863       candidates.end (),
3864       [] (block_symbol &bsym)
3865       {
3866         return bsym.symbol->is_artificial ();
3867       }),
3868      candidates.end ());
3869
3870   int i;
3871   if (candidates.empty ())
3872     error (_("No definition found for %s"), sym->print_name ());
3873   else if (candidates.size () == 1)
3874     i = 0;
3875   else if (context_type != nullptr
3876            && context_type->code () == TYPE_CODE_ENUM)
3877     i = ada_resolve_enum (candidates, sym->linkage_name (), context_type,
3878                           parse_completion);
3879   else if (deprocedure_p && !is_nonfunction (candidates))
3880     {
3881       i = ada_resolve_function
3882         (candidates, NULL, 0,
3883          sym->linkage_name (),
3884          context_type, parse_completion);
3885       if (i < 0)
3886         error (_("Could not find a match for %s"), sym->print_name ());
3887     }
3888   else
3889     {
3890       gdb_printf (_("Multiple matches for %s\n"), sym->print_name ());
3891       user_select_syms (candidates.data (), candidates.size (), 1);
3892       i = 0;
3893     }
3894
3895   tracker->update (candidates[i]);
3896   return candidates[i];
3897 }
3898
3899 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  */
3900 /* The term "match" here is rather loose.  The match is heuristic and
3901    liberal.  */
3902
3903 static int
3904 ada_type_match (struct type *ftype, struct type *atype)
3905 {
3906   ftype = ada_check_typedef (ftype);
3907   atype = ada_check_typedef (atype);
3908
3909   if (ftype->code () == TYPE_CODE_REF)
3910     ftype = ftype->target_type ();
3911   if (atype->code () == TYPE_CODE_REF)
3912     atype = atype->target_type ();
3913
3914   switch (ftype->code ())
3915     {
3916     default:
3917       return ftype->code () == atype->code ();
3918     case TYPE_CODE_PTR:
3919       if (atype->code () != TYPE_CODE_PTR)
3920         return 0;
3921       atype = atype->target_type ();
3922       /* This can only happen if the actual argument is 'null'.  */
3923       if (atype->code () == TYPE_CODE_INT && atype->length () == 0)
3924         return 1;
3925       return ada_type_match (ftype->target_type (), atype);
3926     case TYPE_CODE_INT:
3927     case TYPE_CODE_ENUM:
3928     case TYPE_CODE_RANGE:
3929       switch (atype->code ())
3930         {
3931         case TYPE_CODE_INT:
3932         case TYPE_CODE_ENUM:
3933         case TYPE_CODE_RANGE:
3934           return 1;
3935         default:
3936           return 0;
3937         }
3938
3939     case TYPE_CODE_ARRAY:
3940       return (atype->code () == TYPE_CODE_ARRAY
3941               || ada_is_array_descriptor_type (atype));
3942
3943     case TYPE_CODE_STRUCT:
3944       if (ada_is_array_descriptor_type (ftype))
3945         return (atype->code () == TYPE_CODE_ARRAY
3946                 || ada_is_array_descriptor_type (atype));
3947       else
3948         return (atype->code () == TYPE_CODE_STRUCT
3949                 && !ada_is_array_descriptor_type (atype));
3950
3951     case TYPE_CODE_UNION:
3952     case TYPE_CODE_FLT:
3953       return (atype->code () == ftype->code ());
3954     }
3955 }
3956
3957 /* Return non-zero if the formals of FUNC "sufficiently match" the
3958    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3959    may also be an enumeral, in which case it is treated as a 0-
3960    argument function.  */
3961
3962 static int
3963 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3964 {
3965   int i;
3966   struct type *func_type = func->type ();
3967
3968   if (func->aclass () == LOC_CONST
3969       && func_type->code () == TYPE_CODE_ENUM)
3970     return (n_actuals == 0);
3971   else if (func_type == NULL || func_type->code () != TYPE_CODE_FUNC)
3972     return 0;
3973
3974   if (func_type->num_fields () != n_actuals)
3975     return 0;
3976
3977   for (i = 0; i < n_actuals; i += 1)
3978     {
3979       if (actuals[i] == NULL)
3980         return 0;
3981       else
3982         {
3983           struct type *ftype = ada_check_typedef (func_type->field (i).type ());
3984           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3985
3986           if (!ada_type_match (ftype, atype))
3987             return 0;
3988         }
3989     }
3990   return 1;
3991 }
3992
3993 /* False iff function type FUNC_TYPE definitely does not produce a value
3994    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3995    FUNC_TYPE is not a valid function type with a non-null return type
3996    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3997
3998 static int
3999 return_match (struct type *func_type, struct type *context_type)
4000 {
4001   struct type *return_type;
4002
4003   if (func_type == NULL)
4004     return 1;
4005
4006   if (func_type->code () == TYPE_CODE_FUNC)
4007     return_type = get_base_type (func_type->target_type ());
4008   else
4009     return_type = get_base_type (func_type);
4010   if (return_type == NULL)
4011     return 1;
4012
4013   context_type = get_base_type (context_type);
4014
4015   if (return_type->code () == TYPE_CODE_ENUM)
4016     return context_type == NULL || return_type == context_type;
4017   else if (context_type == NULL)
4018     return return_type->code () != TYPE_CODE_VOID;
4019   else
4020     return return_type->code () == context_type->code ();
4021 }
4022
4023
4024 /* Returns the index in SYMS that contains the symbol for the
4025    function (if any) that matches the types of the NARGS arguments in
4026    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
4027    that returns that type, then eliminate matches that don't.  If
4028    CONTEXT_TYPE is void and there is at least one match that does not
4029    return void, eliminate all matches that do.
4030
4031    Asks the user if there is more than one match remaining.  Returns -1
4032    if there is no such symbol or none is selected.  NAME is used
4033    solely for messages.  May re-arrange and modify SYMS in
4034    the process; the index returned is for the modified vector.  */
4035
4036 static int
4037 ada_resolve_function (std::vector<struct block_symbol> &syms,
4038                       struct value **args, int nargs,
4039                       const char *name, struct type *context_type,
4040                       bool parse_completion)
4041 {
4042   int fallback;
4043   int k;
4044   int m;                        /* Number of hits */
4045
4046   m = 0;
4047   /* In the first pass of the loop, we only accept functions matching
4048      context_type.  If none are found, we add a second pass of the loop
4049      where every function is accepted.  */
4050   for (fallback = 0; m == 0 && fallback < 2; fallback++)
4051     {
4052       for (k = 0; k < syms.size (); k += 1)
4053         {
4054           struct type *type = ada_check_typedef (syms[k].symbol->type ());
4055
4056           if (ada_args_match (syms[k].symbol, args, nargs)
4057               && (fallback || return_match (type, context_type)))
4058             {
4059               syms[m] = syms[k];
4060               m += 1;
4061             }
4062         }
4063     }
4064
4065   /* If we got multiple matches, ask the user which one to use.  Don't do this
4066      interactive thing during completion, though, as the purpose of the
4067      completion is providing a list of all possible matches.  Prompting the
4068      user to filter it down would be completely unexpected in this case.  */
4069   if (m == 0)
4070     return -1;
4071   else if (m > 1 && !parse_completion)
4072     {
4073       gdb_printf (_("Multiple matches for %s\n"), name);
4074       user_select_syms (syms.data (), m, 1);
4075       return 0;
4076     }
4077   return 0;
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 ())
4093         {
4094         case TYPE_CODE_INT:
4095         case TYPE_CODE_FLT:
4096         case TYPE_CODE_FIXED_POINT:
4097           return 1;
4098         case TYPE_CODE_RANGE:
4099           return (type == type->target_type ()
4100                   || numeric_type_p (type->target_type ()));
4101         default:
4102           return 0;
4103         }
4104     }
4105 }
4106
4107 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
4108
4109 static int
4110 integer_type_p (struct type *type)
4111 {
4112   if (type == NULL)
4113     return 0;
4114   else
4115     {
4116       switch (type->code ())
4117         {
4118         case TYPE_CODE_INT:
4119           return 1;
4120         case TYPE_CODE_RANGE:
4121           return (type == type->target_type ()
4122                   || integer_type_p (type->target_type ()));
4123         default:
4124           return 0;
4125         }
4126     }
4127 }
4128
4129 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
4130
4131 static int
4132 scalar_type_p (struct type *type)
4133 {
4134   if (type == NULL)
4135     return 0;
4136   else
4137     {
4138       switch (type->code ())
4139         {
4140         case TYPE_CODE_INT:
4141         case TYPE_CODE_RANGE:
4142         case TYPE_CODE_ENUM:
4143         case TYPE_CODE_FLT:
4144         case TYPE_CODE_FIXED_POINT:
4145           return 1;
4146         default:
4147           return 0;
4148         }
4149     }
4150 }
4151
4152 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
4153
4154 static int
4155 discrete_type_p (struct type *type)
4156 {
4157   if (type == NULL)
4158     return 0;
4159   else
4160     {
4161       switch (type->code ())
4162         {
4163         case TYPE_CODE_INT:
4164         case TYPE_CODE_RANGE:
4165         case TYPE_CODE_ENUM:
4166         case TYPE_CODE_BOOL:
4167           return 1;
4168         default:
4169           return 0;
4170         }
4171     }
4172 }
4173
4174 /* Returns non-zero if OP with operands in the vector ARGS could be
4175    a user-defined function.  Errs on the side of pre-defined operators
4176    (i.e., result 0).  */
4177
4178 static int
4179 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4180 {
4181   struct type *type0 =
4182     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4183   struct type *type1 =
4184     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4185
4186   if (type0 == NULL)
4187     return 0;
4188
4189   switch (op)
4190     {
4191     default:
4192       return 0;
4193
4194     case BINOP_ADD:
4195     case BINOP_SUB:
4196     case BINOP_MUL:
4197     case BINOP_DIV:
4198       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4199
4200     case BINOP_REM:
4201     case BINOP_MOD:
4202     case BINOP_BITWISE_AND:
4203     case BINOP_BITWISE_IOR:
4204     case BINOP_BITWISE_XOR:
4205       return (!(integer_type_p (type0) && integer_type_p (type1)));
4206
4207     case BINOP_EQUAL:
4208     case BINOP_NOTEQUAL:
4209     case BINOP_LESS:
4210     case BINOP_GTR:
4211     case BINOP_LEQ:
4212     case BINOP_GEQ:
4213       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4214
4215     case BINOP_CONCAT:
4216       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4217
4218     case BINOP_EXP:
4219       return (!(numeric_type_p (type0) && integer_type_p (type1)));
4220
4221     case UNOP_NEG:
4222     case UNOP_PLUS:
4223     case UNOP_LOGICAL_NOT:
4224     case UNOP_ABS:
4225       return (!numeric_type_p (type0));
4226
4227     }
4228 }
4229 \f
4230                                 /* Renaming */
4231
4232 /* NOTES: 
4233
4234    1. In the following, we assume that a renaming type's name may
4235       have an ___XD suffix.  It would be nice if this went away at some
4236       point.
4237    2. We handle both the (old) purely type-based representation of 
4238       renamings and the (new) variable-based encoding.  At some point,
4239       it is devoutly to be hoped that the former goes away 
4240       (FIXME: hilfinger-2007-07-09).
4241    3. Subprogram renamings are not implemented, although the XRS
4242       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
4243
4244 /* If SYM encodes a renaming, 
4245
4246        <renaming> renames <renamed entity>,
4247
4248    sets *LEN to the length of the renamed entity's name,
4249    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4250    the string describing the subcomponent selected from the renamed
4251    entity.  Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4252    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4253    are undefined).  Otherwise, returns a value indicating the category
4254    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4255    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4256    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
4257    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4258    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4259    may be NULL, in which case they are not assigned.
4260
4261    [Currently, however, GCC does not generate subprogram renamings.]  */
4262
4263 enum ada_renaming_category
4264 ada_parse_renaming (struct symbol *sym,
4265                     const char **renamed_entity, int *len, 
4266                     const char **renaming_expr)
4267 {
4268   enum ada_renaming_category kind;
4269   const char *info;
4270   const char *suffix;
4271
4272   if (sym == NULL)
4273     return ADA_NOT_RENAMING;
4274   switch (sym->aclass ()) 
4275     {
4276     default:
4277       return ADA_NOT_RENAMING;
4278     case LOC_LOCAL:
4279     case LOC_STATIC:
4280     case LOC_COMPUTED:
4281     case LOC_OPTIMIZED_OUT:
4282       info = strstr (sym->linkage_name (), "___XR");
4283       if (info == NULL)
4284         return ADA_NOT_RENAMING;
4285       switch (info[5])
4286         {
4287         case '_':
4288           kind = ADA_OBJECT_RENAMING;
4289           info += 6;
4290           break;
4291         case 'E':
4292           kind = ADA_EXCEPTION_RENAMING;
4293           info += 7;
4294           break;
4295         case 'P':
4296           kind = ADA_PACKAGE_RENAMING;
4297           info += 7;
4298           break;
4299         case 'S':
4300           kind = ADA_SUBPROGRAM_RENAMING;
4301           info += 7;
4302           break;
4303         default:
4304           return ADA_NOT_RENAMING;
4305         }
4306     }
4307
4308   if (renamed_entity != NULL)
4309     *renamed_entity = info;
4310   suffix = strstr (info, "___XE");
4311   if (suffix == NULL || suffix == info)
4312     return ADA_NOT_RENAMING;
4313   if (len != NULL)
4314     *len = strlen (info) - strlen (suffix);
4315   suffix += 5;
4316   if (renaming_expr != NULL)
4317     *renaming_expr = suffix;
4318   return kind;
4319 }
4320
4321 /* Compute the value of the given RENAMING_SYM, which is expected to
4322    be a symbol encoding a renaming expression.  BLOCK is the block
4323    used to evaluate the renaming.  */
4324
4325 static struct value *
4326 ada_read_renaming_var_value (struct symbol *renaming_sym,
4327                              const struct block *block)
4328 {
4329   const char *sym_name;
4330
4331   sym_name = renaming_sym->linkage_name ();
4332   expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4333   return evaluate_expression (expr.get ());
4334 }
4335 \f
4336
4337                                 /* Evaluation: Function Calls */
4338
4339 /* Return an lvalue containing the value VAL.  This is the identity on
4340    lvalues, and otherwise has the side-effect of allocating memory
4341    in the inferior where a copy of the value contents is copied.  */
4342
4343 static struct value *
4344 ensure_lval (struct value *val)
4345 {
4346   if (VALUE_LVAL (val) == not_lval
4347       || VALUE_LVAL (val) == lval_internalvar)
4348     {
4349       int len = ada_check_typedef (value_type (val))->length ();
4350       const CORE_ADDR addr =
4351         value_as_long (value_allocate_space_in_inferior (len));
4352
4353       VALUE_LVAL (val) = lval_memory;
4354       set_value_address (val, addr);
4355       write_memory (addr, value_contents (val).data (), len);
4356     }
4357
4358   return val;
4359 }
4360
4361 /* Given ARG, a value of type (pointer or reference to a)*
4362    structure/union, extract the component named NAME from the ultimate
4363    target structure/union and return it as a value with its
4364    appropriate type.
4365
4366    The routine searches for NAME among all members of the structure itself
4367    and (recursively) among all members of any wrapper members
4368    (e.g., '_parent').
4369
4370    If NO_ERR, then simply return NULL in case of error, rather than
4371    calling error.  */
4372
4373 static struct value *
4374 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
4375 {
4376   struct type *t, *t1;
4377   struct value *v;
4378   int check_tag;
4379
4380   v = NULL;
4381   t1 = t = ada_check_typedef (value_type (arg));
4382   if (t->code () == TYPE_CODE_REF)
4383     {
4384       t1 = t->target_type ();
4385       if (t1 == NULL)
4386         goto BadValue;
4387       t1 = ada_check_typedef (t1);
4388       if (t1->code () == TYPE_CODE_PTR)
4389         {
4390           arg = coerce_ref (arg);
4391           t = t1;
4392         }
4393     }
4394
4395   while (t->code () == TYPE_CODE_PTR)
4396     {
4397       t1 = t->target_type ();
4398       if (t1 == NULL)
4399         goto BadValue;
4400       t1 = ada_check_typedef (t1);
4401       if (t1->code () == TYPE_CODE_PTR)
4402         {
4403           arg = value_ind (arg);
4404           t = t1;
4405         }
4406       else
4407         break;
4408     }
4409
4410   if (t1->code () != TYPE_CODE_STRUCT && t1->code () != TYPE_CODE_UNION)
4411     goto BadValue;
4412
4413   if (t1 == t)
4414     v = ada_search_struct_field (name, arg, 0, t);
4415   else
4416     {
4417       int bit_offset, bit_size, byte_offset;
4418       struct type *field_type;
4419       CORE_ADDR address;
4420
4421       if (t->code () == TYPE_CODE_PTR)
4422         address = value_address (ada_value_ind (arg));
4423       else
4424         address = value_address (ada_coerce_ref (arg));
4425
4426       /* Check to see if this is a tagged type.  We also need to handle
4427          the case where the type is a reference to a tagged type, but
4428          we have to be careful to exclude pointers to tagged types.
4429          The latter should be shown as usual (as a pointer), whereas
4430          a reference should mostly be transparent to the user.  */
4431
4432       if (ada_is_tagged_type (t1, 0)
4433           || (t1->code () == TYPE_CODE_REF
4434               && ada_is_tagged_type (t1->target_type (), 0)))
4435         {
4436           /* We first try to find the searched field in the current type.
4437              If not found then let's look in the fixed type.  */
4438
4439           if (!find_struct_field (name, t1, 0,
4440                                   nullptr, nullptr, nullptr,
4441                                   nullptr, nullptr))
4442             check_tag = 1;
4443           else
4444             check_tag = 0;
4445         }
4446       else
4447         check_tag = 0;
4448
4449       /* Convert to fixed type in all cases, so that we have proper
4450          offsets to each field in unconstrained record types.  */
4451       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4452                               address, NULL, check_tag);
4453
4454       /* Resolve the dynamic type as well.  */
4455       arg = value_from_contents_and_address (t1, nullptr, address);
4456       t1 = value_type (arg);
4457
4458       if (find_struct_field (name, t1, 0,
4459                              &field_type, &byte_offset, &bit_offset,
4460                              &bit_size, NULL))
4461         {
4462           if (bit_size != 0)
4463             {
4464               if (t->code () == TYPE_CODE_REF)
4465                 arg = ada_coerce_ref (arg);
4466               else
4467                 arg = ada_value_ind (arg);
4468               v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4469                                                   bit_offset, bit_size,
4470                                                   field_type);
4471             }
4472           else
4473             v = value_at_lazy (field_type, address + byte_offset);
4474         }
4475     }
4476
4477   if (v != NULL || no_err)
4478     return v;
4479   else
4480     error (_("There is no member named %s."), name);
4481
4482  BadValue:
4483   if (no_err)
4484     return NULL;
4485   else
4486     error (_("Attempt to extract a component of "
4487              "a value that is not a record."));
4488 }
4489
4490 /* Return the value ACTUAL, converted to be an appropriate value for a
4491    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
4492    allocating any necessary descriptors (fat pointers), or copies of
4493    values not residing in memory, updating it as needed.  */
4494
4495 struct value *
4496 ada_convert_actual (struct value *actual, struct type *formal_type0)
4497 {
4498   struct type *actual_type = ada_check_typedef (value_type (actual));
4499   struct type *formal_type = ada_check_typedef (formal_type0);
4500   struct type *formal_target =
4501     formal_type->code () == TYPE_CODE_PTR
4502     ? ada_check_typedef (formal_type->target_type ()) : formal_type;
4503   struct type *actual_target =
4504     actual_type->code () == TYPE_CODE_PTR
4505     ? ada_check_typedef (actual_type->target_type ()) : actual_type;
4506
4507   if (ada_is_array_descriptor_type (formal_target)
4508       && actual_target->code () == TYPE_CODE_ARRAY)
4509     return make_array_descriptor (formal_type, actual);
4510   else if (formal_type->code () == TYPE_CODE_PTR
4511            || formal_type->code () == TYPE_CODE_REF)
4512     {
4513       struct value *result;
4514
4515       if (formal_target->code () == TYPE_CODE_ARRAY
4516           && ada_is_array_descriptor_type (actual_target))
4517         result = desc_data (actual);
4518       else if (formal_type->code () != TYPE_CODE_PTR)
4519         {
4520           if (VALUE_LVAL (actual) != lval_memory)
4521             {
4522               struct value *val;
4523
4524               actual_type = ada_check_typedef (value_type (actual));
4525               val = allocate_value (actual_type);
4526               copy (value_contents (actual), value_contents_raw (val));
4527               actual = ensure_lval (val);
4528             }
4529           result = value_addr (actual);
4530         }
4531       else
4532         return actual;
4533       return value_cast_pointers (formal_type, result, 0);
4534     }
4535   else if (actual_type->code () == TYPE_CODE_PTR)
4536     return ada_value_ind (actual);
4537   else if (ada_is_aligner_type (formal_type))
4538     {
4539       /* We need to turn this parameter into an aligner type
4540          as well.  */
4541       struct value *aligner = allocate_value (formal_type);
4542       struct value *component = ada_value_struct_elt (aligner, "F", 0);
4543
4544       value_assign_to_component (aligner, component, actual);
4545       return aligner;
4546     }
4547
4548   return actual;
4549 }
4550
4551 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4552    type TYPE.  This is usually an inefficient no-op except on some targets
4553    (such as AVR) where the representation of a pointer and an address
4554    differs.  */
4555
4556 static CORE_ADDR
4557 value_pointer (struct value *value, struct type *type)
4558 {
4559   unsigned len = type->length ();
4560   gdb_byte *buf = (gdb_byte *) alloca (len);
4561   CORE_ADDR addr;
4562
4563   addr = value_address (value);
4564   gdbarch_address_to_pointer (type->arch (), type, buf, addr);
4565   addr = extract_unsigned_integer (buf, len, type_byte_order (type));
4566   return addr;
4567 }
4568
4569
4570 /* Push a descriptor of type TYPE for array value ARR on the stack at
4571    *SP, updating *SP to reflect the new descriptor.  Return either
4572    an lvalue representing the new descriptor, or (if TYPE is a pointer-
4573    to-descriptor type rather than a descriptor type), a struct value *
4574    representing a pointer to this descriptor.  */
4575
4576 static struct value *
4577 make_array_descriptor (struct type *type, struct value *arr)
4578 {
4579   struct type *bounds_type = desc_bounds_type (type);
4580   struct type *desc_type = desc_base_type (type);
4581   struct value *descriptor = allocate_value (desc_type);
4582   struct value *bounds = allocate_value (bounds_type);
4583   int i;
4584
4585   for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4586        i > 0; i -= 1)
4587     {
4588       modify_field (value_type (bounds),
4589                     value_contents_writeable (bounds).data (),
4590                     ada_array_bound (arr, i, 0),
4591                     desc_bound_bitpos (bounds_type, i, 0),
4592                     desc_bound_bitsize (bounds_type, i, 0));
4593       modify_field (value_type (bounds),
4594                     value_contents_writeable (bounds).data (),
4595                     ada_array_bound (arr, i, 1),
4596                     desc_bound_bitpos (bounds_type, i, 1),
4597                     desc_bound_bitsize (bounds_type, i, 1));
4598     }
4599
4600   bounds = ensure_lval (bounds);
4601
4602   modify_field (value_type (descriptor),
4603                 value_contents_writeable (descriptor).data (),
4604                 value_pointer (ensure_lval (arr),
4605                                desc_type->field (0).type ()),
4606                 fat_pntr_data_bitpos (desc_type),
4607                 fat_pntr_data_bitsize (desc_type));
4608
4609   modify_field (value_type (descriptor),
4610                 value_contents_writeable (descriptor).data (),
4611                 value_pointer (bounds,
4612                                desc_type->field (1).type ()),
4613                 fat_pntr_bounds_bitpos (desc_type),
4614                 fat_pntr_bounds_bitsize (desc_type));
4615
4616   descriptor = ensure_lval (descriptor);
4617
4618   if (type->code () == TYPE_CODE_PTR)
4619     return value_addr (descriptor);
4620   else
4621     return descriptor;
4622 }
4623 \f
4624                                 /* Symbol Cache Module */
4625
4626 /* Performance measurements made as of 2010-01-15 indicate that
4627    this cache does bring some noticeable improvements.  Depending
4628    on the type of entity being printed, the cache can make it as much
4629    as an order of magnitude faster than without it.
4630
4631    The descriptive type DWARF extension has significantly reduced
4632    the need for this cache, at least when DWARF is being used.  However,
4633    even in this case, some expensive name-based symbol searches are still
4634    sometimes necessary - to find an XVZ variable, mostly.  */
4635
4636 /* Return the symbol cache associated to the given program space PSPACE.
4637    If not allocated for this PSPACE yet, allocate and initialize one.  */
4638
4639 static struct ada_symbol_cache *
4640 ada_get_symbol_cache (struct program_space *pspace)
4641 {
4642   struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4643
4644   if (pspace_data->sym_cache == nullptr)
4645     pspace_data->sym_cache.reset (new ada_symbol_cache);
4646
4647   return pspace_data->sym_cache.get ();
4648 }
4649
4650 /* Clear all entries from the symbol cache.  */
4651
4652 static void
4653 ada_clear_symbol_cache ()
4654 {
4655   struct ada_pspace_data *pspace_data
4656     = get_ada_pspace_data (current_program_space);
4657
4658   if (pspace_data->sym_cache != nullptr)
4659     pspace_data->sym_cache.reset ();
4660 }
4661
4662 /* Search our cache for an entry matching NAME and DOMAIN.
4663    Return it if found, or NULL otherwise.  */
4664
4665 static struct cache_entry **
4666 find_entry (const char *name, domain_enum domain)
4667 {
4668   struct ada_symbol_cache *sym_cache
4669     = ada_get_symbol_cache (current_program_space);
4670   int h = msymbol_hash (name) % HASH_SIZE;
4671   struct cache_entry **e;
4672
4673   for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4674     {
4675       if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4676         return e;
4677     }
4678   return NULL;
4679 }
4680
4681 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4682    Return 1 if found, 0 otherwise.
4683
4684    If an entry was found and SYM is not NULL, set *SYM to the entry's
4685    SYM.  Same principle for BLOCK if not NULL.  */
4686
4687 static int
4688 lookup_cached_symbol (const char *name, domain_enum domain,
4689                       struct symbol **sym, const struct block **block)
4690 {
4691   struct cache_entry **e = find_entry (name, domain);
4692
4693   if (e == NULL)
4694     return 0;
4695   if (sym != NULL)
4696     *sym = (*e)->sym;
4697   if (block != NULL)
4698     *block = (*e)->block;
4699   return 1;
4700 }
4701
4702 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4703    in domain DOMAIN, save this result in our symbol cache.  */
4704
4705 static void
4706 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4707               const struct block *block)
4708 {
4709   struct ada_symbol_cache *sym_cache
4710     = ada_get_symbol_cache (current_program_space);
4711   int h;
4712   struct cache_entry *e;
4713
4714   /* Symbols for builtin types don't have a block.
4715      For now don't cache such symbols.  */
4716   if (sym != NULL && !sym->is_objfile_owned ())
4717     return;
4718
4719   /* If the symbol is a local symbol, then do not cache it, as a search
4720      for that symbol depends on the context.  To determine whether
4721      the symbol is local or not, we check the block where we found it
4722      against the global and static blocks of its associated symtab.  */
4723   if (sym != nullptr)
4724     {
4725       const blockvector &bv = *sym->symtab ()->compunit ()->blockvector ();
4726
4727       if (bv.global_block () != block && bv.static_block () != block)
4728         return;
4729     }
4730
4731   h = msymbol_hash (name) % HASH_SIZE;
4732   e = XOBNEW (&sym_cache->cache_space, cache_entry);
4733   e->next = sym_cache->root[h];
4734   sym_cache->root[h] = e;
4735   e->name = obstack_strdup (&sym_cache->cache_space, name);
4736   e->sym = sym;
4737   e->domain = domain;
4738   e->block = block;
4739 }
4740 \f
4741                                 /* Symbol Lookup */
4742
4743 /* Return the symbol name match type that should be used used when
4744    searching for all symbols matching LOOKUP_NAME.
4745
4746    LOOKUP_NAME is expected to be a symbol name after transformation
4747    for Ada lookups.  */
4748
4749 static symbol_name_match_type
4750 name_match_type_from_name (const char *lookup_name)
4751 {
4752   return (strstr (lookup_name, "__") == NULL
4753           ? symbol_name_match_type::WILD
4754           : symbol_name_match_type::FULL);
4755 }
4756
4757 /* Return the result of a standard (literal, C-like) lookup of NAME in
4758    given DOMAIN, visible from lexical block BLOCK.  */
4759
4760 static struct symbol *
4761 standard_lookup (const char *name, const struct block *block,
4762                  domain_enum domain)
4763 {
4764   /* Initialize it just to avoid a GCC false warning.  */
4765   struct block_symbol sym = {};
4766
4767   if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4768     return sym.symbol;
4769   ada_lookup_encoded_symbol (name, block, domain, &sym);
4770   cache_symbol (name, domain, sym.symbol, sym.block);
4771   return sym.symbol;
4772 }
4773
4774
4775 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4776    in the symbol fields of SYMS.  We treat enumerals as functions, 
4777    since they contend in overloading in the same way.  */
4778 static int
4779 is_nonfunction (const std::vector<struct block_symbol> &syms)
4780 {
4781   for (const block_symbol &sym : syms)
4782     if (sym.symbol->type ()->code () != TYPE_CODE_FUNC
4783         && (sym.symbol->type ()->code () != TYPE_CODE_ENUM
4784             || sym.symbol->aclass () != LOC_CONST))
4785       return 1;
4786
4787   return 0;
4788 }
4789
4790 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4791    struct types.  Otherwise, they may not.  */
4792
4793 static int
4794 equiv_types (struct type *type0, struct type *type1)
4795 {
4796   if (type0 == type1)
4797     return 1;
4798   if (type0 == NULL || type1 == NULL
4799       || type0->code () != type1->code ())
4800     return 0;
4801   if ((type0->code () == TYPE_CODE_STRUCT
4802        || type0->code () == TYPE_CODE_ENUM)
4803       && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4804       && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4805     return 1;
4806
4807   return 0;
4808 }
4809
4810 /* True iff SYM0 represents the same entity as SYM1, or one that is
4811    no more defined than that of SYM1.  */
4812
4813 static int
4814 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4815 {
4816   if (sym0 == sym1)
4817     return 1;
4818   if (sym0->domain () != sym1->domain ()
4819       || sym0->aclass () != sym1->aclass ())
4820     return 0;
4821
4822   switch (sym0->aclass ())
4823     {
4824     case LOC_UNDEF:
4825       return 1;
4826     case LOC_TYPEDEF:
4827       {
4828         struct type *type0 = sym0->type ();
4829         struct type *type1 = sym1->type ();
4830         const char *name0 = sym0->linkage_name ();
4831         const char *name1 = sym1->linkage_name ();
4832         int len0 = strlen (name0);
4833
4834         return
4835           type0->code () == type1->code ()
4836           && (equiv_types (type0, type1)
4837               || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4838                   && startswith (name1 + len0, "___XV")));
4839       }
4840     case LOC_CONST:
4841       return sym0->value_longest () == sym1->value_longest ()
4842         && equiv_types (sym0->type (), sym1->type ());
4843
4844     case LOC_STATIC:
4845       {
4846         const char *name0 = sym0->linkage_name ();
4847         const char *name1 = sym1->linkage_name ();
4848         return (strcmp (name0, name1) == 0
4849                 && sym0->value_address () == sym1->value_address ());
4850       }
4851
4852     default:
4853       return 0;
4854     }
4855 }
4856
4857 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4858    records in RESULT.  Do nothing if SYM is a duplicate.  */
4859
4860 static void
4861 add_defn_to_vec (std::vector<struct block_symbol> &result,
4862                  struct symbol *sym,
4863                  const struct block *block)
4864 {
4865   /* Do not try to complete stub types, as the debugger is probably
4866      already scanning all symbols matching a certain name at the
4867      time when this function is called.  Trying to replace the stub
4868      type by its associated full type will cause us to restart a scan
4869      which may lead to an infinite recursion.  Instead, the client
4870      collecting the matching symbols will end up collecting several
4871      matches, with at least one of them complete.  It can then filter
4872      out the stub ones if needed.  */
4873
4874   for (int i = result.size () - 1; i >= 0; i -= 1)
4875     {
4876       if (lesseq_defined_than (sym, result[i].symbol))
4877         return;
4878       else if (lesseq_defined_than (result[i].symbol, sym))
4879         {
4880           result[i].symbol = sym;
4881           result[i].block = block;
4882           return;
4883         }
4884     }
4885
4886   struct block_symbol info;
4887   info.symbol = sym;
4888   info.block = block;
4889   result.push_back (info);
4890 }
4891
4892 /* Return a bound minimal symbol matching NAME according to Ada
4893    decoding rules.  Returns an invalid symbol if there is no such
4894    minimal symbol.  Names prefixed with "standard__" are handled
4895    specially: "standard__" is first stripped off, and only static and
4896    global symbols are searched.  */
4897
4898 struct bound_minimal_symbol
4899 ada_lookup_simple_minsym (const char *name)
4900 {
4901   struct bound_minimal_symbol result;
4902
4903   symbol_name_match_type match_type = name_match_type_from_name (name);
4904   lookup_name_info lookup_name (name, match_type);
4905
4906   symbol_name_matcher_ftype *match_name
4907     = ada_get_symbol_name_matcher (lookup_name);
4908
4909   for (objfile *objfile : current_program_space->objfiles ())
4910     {
4911       for (minimal_symbol *msymbol : objfile->msymbols ())
4912         {
4913           if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4914               && msymbol->type () != mst_solib_trampoline)
4915             {
4916               result.minsym = msymbol;
4917               result.objfile = objfile;
4918               break;
4919             }
4920         }
4921     }
4922
4923   return result;
4924 }
4925
4926 /* True if TYPE is definitely an artificial type supplied to a symbol
4927    for which no debugging information was given in the symbol file.  */
4928
4929 static int
4930 is_nondebugging_type (struct type *type)
4931 {
4932   const char *name = ada_type_name (type);
4933
4934   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4935 }
4936
4937 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4938    that are deemed "identical" for practical purposes.
4939
4940    This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4941    types and that their number of enumerals is identical (in other
4942    words, type1->num_fields () == type2->num_fields ()).  */
4943
4944 static int
4945 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4946 {
4947   int i;
4948
4949   /* The heuristic we use here is fairly conservative.  We consider
4950      that 2 enumerate types are identical if they have the same
4951      number of enumerals and that all enumerals have the same
4952      underlying value and name.  */
4953
4954   /* All enums in the type should have an identical underlying value.  */
4955   for (i = 0; i < type1->num_fields (); i++)
4956     if (type1->field (i).loc_enumval () != type2->field (i).loc_enumval ())
4957       return 0;
4958
4959   /* All enumerals should also have the same name (modulo any numerical
4960      suffix).  */
4961   for (i = 0; i < type1->num_fields (); i++)
4962     {
4963       const char *name_1 = type1->field (i).name ();
4964       const char *name_2 = type2->field (i).name ();
4965       int len_1 = strlen (name_1);
4966       int len_2 = strlen (name_2);
4967
4968       ada_remove_trailing_digits (type1->field (i).name (), &len_1);
4969       ada_remove_trailing_digits (type2->field (i).name (), &len_2);
4970       if (len_1 != len_2
4971           || strncmp (type1->field (i).name (),
4972                       type2->field (i).name (),
4973                       len_1) != 0)
4974         return 0;
4975     }
4976
4977   return 1;
4978 }
4979
4980 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4981    that are deemed "identical" for practical purposes.  Sometimes,
4982    enumerals are not strictly identical, but their types are so similar
4983    that they can be considered identical.
4984
4985    For instance, consider the following code:
4986
4987       type Color is (Black, Red, Green, Blue, White);
4988       type RGB_Color is new Color range Red .. Blue;
4989
4990    Type RGB_Color is a subrange of an implicit type which is a copy
4991    of type Color. If we call that implicit type RGB_ColorB ("B" is
4992    for "Base Type"), then type RGB_ColorB is a copy of type Color.
4993    As a result, when an expression references any of the enumeral
4994    by name (Eg. "print green"), the expression is technically
4995    ambiguous and the user should be asked to disambiguate. But
4996    doing so would only hinder the user, since it wouldn't matter
4997    what choice he makes, the outcome would always be the same.
4998    So, for practical purposes, we consider them as the same.  */
4999
5000 static int
5001 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
5002 {
5003   int i;
5004
5005   /* Before performing a thorough comparison check of each type,
5006      we perform a series of inexpensive checks.  We expect that these
5007      checks will quickly fail in the vast majority of cases, and thus
5008      help prevent the unnecessary use of a more expensive comparison.
5009      Said comparison also expects us to make some of these checks
5010      (see ada_identical_enum_types_p).  */
5011
5012   /* Quick check: All symbols should have an enum type.  */
5013   for (i = 0; i < syms.size (); i++)
5014     if (syms[i].symbol->type ()->code () != TYPE_CODE_ENUM)
5015       return 0;
5016
5017   /* Quick check: They should all have the same value.  */
5018   for (i = 1; i < syms.size (); i++)
5019     if (syms[i].symbol->value_longest () != syms[0].symbol->value_longest ())
5020       return 0;
5021
5022   /* Quick check: They should all have the same number of enumerals.  */
5023   for (i = 1; i < syms.size (); i++)
5024     if (syms[i].symbol->type ()->num_fields ()
5025         != syms[0].symbol->type ()->num_fields ())
5026       return 0;
5027
5028   /* All the sanity checks passed, so we might have a set of
5029      identical enumeration types.  Perform a more complete
5030      comparison of the type of each symbol.  */
5031   for (i = 1; i < syms.size (); i++)
5032     if (!ada_identical_enum_types_p (syms[i].symbol->type (),
5033                                      syms[0].symbol->type ()))
5034       return 0;
5035
5036   return 1;
5037 }
5038
5039 /* Remove any non-debugging symbols in SYMS that definitely
5040    duplicate other symbols in the list (The only case I know of where
5041    this happens is when object files containing stabs-in-ecoff are
5042    linked with files containing ordinary ecoff debugging symbols (or no
5043    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.  */
5044
5045 static void
5046 remove_extra_symbols (std::vector<struct block_symbol> *syms)
5047 {
5048   int i, j;
5049
5050   /* We should never be called with less than 2 symbols, as there
5051      cannot be any extra symbol in that case.  But it's easy to
5052      handle, since we have nothing to do in that case.  */
5053   if (syms->size () < 2)
5054     return;
5055
5056   i = 0;
5057   while (i < syms->size ())
5058     {
5059       int remove_p = 0;
5060
5061       /* If two symbols have the same name and one of them is a stub type,
5062          the get rid of the stub.  */
5063
5064       if ((*syms)[i].symbol->type ()->is_stub ()
5065           && (*syms)[i].symbol->linkage_name () != NULL)
5066         {
5067           for (j = 0; j < syms->size (); j++)
5068             {
5069               if (j != i
5070                   && !(*syms)[j].symbol->type ()->is_stub ()
5071                   && (*syms)[j].symbol->linkage_name () != NULL
5072                   && strcmp ((*syms)[i].symbol->linkage_name (),
5073                              (*syms)[j].symbol->linkage_name ()) == 0)
5074                 remove_p = 1;
5075             }
5076         }
5077
5078       /* Two symbols with the same name, same class and same address
5079          should be identical.  */
5080
5081       else if ((*syms)[i].symbol->linkage_name () != NULL
5082           && (*syms)[i].symbol->aclass () == LOC_STATIC
5083           && is_nondebugging_type ((*syms)[i].symbol->type ()))
5084         {
5085           for (j = 0; j < syms->size (); j += 1)
5086             {
5087               if (i != j
5088                   && (*syms)[j].symbol->linkage_name () != NULL
5089                   && strcmp ((*syms)[i].symbol->linkage_name (),
5090                              (*syms)[j].symbol->linkage_name ()) == 0
5091                   && ((*syms)[i].symbol->aclass ()
5092                       == (*syms)[j].symbol->aclass ())
5093                   && (*syms)[i].symbol->value_address ()
5094                   == (*syms)[j].symbol->value_address ())
5095                 remove_p = 1;
5096             }
5097         }
5098       
5099       if (remove_p)
5100         syms->erase (syms->begin () + i);
5101       else
5102         i += 1;
5103     }
5104
5105   /* If all the remaining symbols are identical enumerals, then
5106      just keep the first one and discard the rest.
5107
5108      Unlike what we did previously, we do not discard any entry
5109      unless they are ALL identical.  This is because the symbol
5110      comparison is not a strict comparison, but rather a practical
5111      comparison.  If all symbols are considered identical, then
5112      we can just go ahead and use the first one and discard the rest.
5113      But if we cannot reduce the list to a single element, we have
5114      to ask the user to disambiguate anyways.  And if we have to
5115      present a multiple-choice menu, it's less confusing if the list
5116      isn't missing some choices that were identical and yet distinct.  */
5117   if (symbols_are_identical_enums (*syms))
5118     syms->resize (1);
5119 }
5120
5121 /* Given a type that corresponds to a renaming entity, use the type name
5122    to extract the scope (package name or function name, fully qualified,
5123    and following the GNAT encoding convention) where this renaming has been
5124    defined.  */
5125
5126 static std::string
5127 xget_renaming_scope (struct type *renaming_type)
5128 {
5129   /* The renaming types adhere to the following convention:
5130      <scope>__<rename>___<XR extension>.
5131      So, to extract the scope, we search for the "___XR" extension,
5132      and then backtrack until we find the first "__".  */
5133
5134   const char *name = renaming_type->name ();
5135   const char *suffix = strstr (name, "___XR");
5136   const char *last;
5137
5138   /* Now, backtrack a bit until we find the first "__".  Start looking
5139      at suffix - 3, as the <rename> part is at least one character long.  */
5140
5141   for (last = suffix - 3; last > name; last--)
5142     if (last[0] == '_' && last[1] == '_')
5143       break;
5144
5145   /* Make a copy of scope and return it.  */
5146   return std::string (name, last);
5147 }
5148
5149 /* Return nonzero if NAME corresponds to a package name.  */
5150
5151 static int
5152 is_package_name (const char *name)
5153 {
5154   /* Here, We take advantage of the fact that no symbols are generated
5155      for packages, while symbols are generated for each function.
5156      So the condition for NAME represent a package becomes equivalent
5157      to NAME not existing in our list of symbols.  There is only one
5158      small complication with library-level functions (see below).  */
5159
5160   /* If it is a function that has not been defined at library level,
5161      then we should be able to look it up in the symbols.  */
5162   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5163     return 0;
5164
5165   /* Library-level function names start with "_ada_".  See if function
5166      "_ada_" followed by NAME can be found.  */
5167
5168   /* Do a quick check that NAME does not contain "__", since library-level
5169      functions names cannot contain "__" in them.  */
5170   if (strstr (name, "__") != NULL)
5171     return 0;
5172
5173   std::string fun_name = string_printf ("_ada_%s", name);
5174
5175   return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
5176 }
5177
5178 /* Return nonzero if SYM corresponds to a renaming entity that is
5179    not visible from FUNCTION_NAME.  */
5180
5181 static int
5182 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5183 {
5184   if (sym->aclass () != LOC_TYPEDEF)
5185     return 0;
5186
5187   std::string scope = xget_renaming_scope (sym->type ());
5188
5189   /* If the rename has been defined in a package, then it is visible.  */
5190   if (is_package_name (scope.c_str ()))
5191     return 0;
5192
5193   /* Check that the rename is in the current function scope by checking
5194      that its name starts with SCOPE.  */
5195
5196   /* If the function name starts with "_ada_", it means that it is
5197      a library-level function.  Strip this prefix before doing the
5198      comparison, as the encoding for the renaming does not contain
5199      this prefix.  */
5200   if (startswith (function_name, "_ada_"))
5201     function_name += 5;
5202
5203   return !startswith (function_name, scope.c_str ());
5204 }
5205
5206 /* Remove entries from SYMS that corresponds to a renaming entity that
5207    is not visible from the function associated with CURRENT_BLOCK or
5208    that is superfluous due to the presence of more specific renaming
5209    information.  Places surviving symbols in the initial entries of
5210    SYMS.
5211
5212    Rationale:
5213    First, in cases where an object renaming is implemented as a
5214    reference variable, GNAT may produce both the actual reference
5215    variable and the renaming encoding.  In this case, we discard the
5216    latter.
5217
5218    Second, GNAT emits a type following a specified encoding for each renaming
5219    entity.  Unfortunately, STABS currently does not support the definition
5220    of types that are local to a given lexical block, so all renamings types
5221    are emitted at library level.  As a consequence, if an application
5222    contains two renaming entities using the same name, and a user tries to
5223    print the value of one of these entities, the result of the ada symbol
5224    lookup will also contain the wrong renaming type.
5225
5226    This function partially covers for this limitation by attempting to
5227    remove from the SYMS list renaming symbols that should be visible
5228    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
5229    method with the current information available.  The implementation
5230    below has a couple of limitations (FIXME: brobecker-2003-05-12):  
5231    
5232       - When the user tries to print a rename in a function while there
5233         is another rename entity defined in a package:  Normally, the
5234         rename in the function has precedence over the rename in the
5235         package, so the latter should be removed from the list.  This is
5236         currently not the case.
5237         
5238       - This function will incorrectly remove valid renames if
5239         the CURRENT_BLOCK corresponds to a function which symbol name
5240         has been changed by an "Export" pragma.  As a consequence,
5241         the user will be unable to print such rename entities.  */
5242
5243 static void
5244 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5245                              const struct block *current_block)
5246 {
5247   struct symbol *current_function;
5248   const char *current_function_name;
5249   int i;
5250   int is_new_style_renaming;
5251
5252   /* If there is both a renaming foo___XR... encoded as a variable and
5253      a simple variable foo in the same block, discard the latter.
5254      First, zero out such symbols, then compress.  */
5255   is_new_style_renaming = 0;
5256   for (i = 0; i < syms->size (); i += 1)
5257     {
5258       struct symbol *sym = (*syms)[i].symbol;
5259       const struct block *block = (*syms)[i].block;
5260       const char *name;
5261       const char *suffix;
5262
5263       if (sym == NULL || sym->aclass () == LOC_TYPEDEF)
5264         continue;
5265       name = sym->linkage_name ();
5266       suffix = strstr (name, "___XR");
5267
5268       if (suffix != NULL)
5269         {
5270           int name_len = suffix - name;
5271           int j;
5272
5273           is_new_style_renaming = 1;
5274           for (j = 0; j < syms->size (); j += 1)
5275             if (i != j && (*syms)[j].symbol != NULL
5276                 && strncmp (name, (*syms)[j].symbol->linkage_name (),
5277                             name_len) == 0
5278                 && block == (*syms)[j].block)
5279               (*syms)[j].symbol = NULL;
5280         }
5281     }
5282   if (is_new_style_renaming)
5283     {
5284       int j, k;
5285
5286       for (j = k = 0; j < syms->size (); j += 1)
5287         if ((*syms)[j].symbol != NULL)
5288             {
5289               (*syms)[k] = (*syms)[j];
5290               k += 1;
5291             }
5292       syms->resize (k);
5293       return;
5294     }
5295
5296   /* Extract the function name associated to CURRENT_BLOCK.
5297      Abort if unable to do so.  */
5298
5299   if (current_block == NULL)
5300     return;
5301
5302   current_function = block_linkage_function (current_block);
5303   if (current_function == NULL)
5304     return;
5305
5306   current_function_name = current_function->linkage_name ();
5307   if (current_function_name == NULL)
5308     return;
5309
5310   /* Check each of the symbols, and remove it from the list if it is
5311      a type corresponding to a renaming that is out of the scope of
5312      the current block.  */
5313
5314   i = 0;
5315   while (i < syms->size ())
5316     {
5317       if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
5318           == ADA_OBJECT_RENAMING
5319           && old_renaming_is_invisible ((*syms)[i].symbol,
5320                                         current_function_name))
5321         syms->erase (syms->begin () + i);
5322       else
5323         i += 1;
5324     }
5325 }
5326
5327 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
5328    whose name and domain match LOOKUP_NAME and DOMAIN respectively.
5329
5330    Note: This function assumes that RESULT is empty.  */
5331
5332 static void
5333 ada_add_local_symbols (std::vector<struct block_symbol> &result,
5334                        const lookup_name_info &lookup_name,
5335                        const struct block *block, domain_enum domain)
5336 {
5337   while (block != NULL)
5338     {
5339       ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5340
5341       /* If we found a non-function match, assume that's the one.  We
5342          only check this when finding a function boundary, so that we
5343          can accumulate all results from intervening blocks first.  */
5344       if (block->function () != nullptr && is_nonfunction (result))
5345         return;
5346
5347       block = block->superblock ();
5348     }
5349 }
5350
5351 /* An object of this type is used as the callback argument when
5352    calling the map_matching_symbols method.  */
5353
5354 struct match_data
5355 {
5356   explicit match_data (std::vector<struct block_symbol> *rp)
5357     : resultp (rp)
5358   {
5359   }
5360   DISABLE_COPY_AND_ASSIGN (match_data);
5361
5362   bool operator() (struct block_symbol *bsym);
5363
5364   struct objfile *objfile = nullptr;
5365   std::vector<struct block_symbol> *resultp;
5366   struct symbol *arg_sym = nullptr;
5367   bool found_sym = false;
5368 };
5369
5370 /* A callback for add_nonlocal_symbols that adds symbol, found in
5371    BSYM, to a list of symbols.  */
5372
5373 bool
5374 match_data::operator() (struct block_symbol *bsym)
5375 {
5376   const struct block *block = bsym->block;
5377   struct symbol *sym = bsym->symbol;
5378
5379   if (sym == NULL)
5380     {
5381       if (!found_sym && arg_sym != NULL)
5382         add_defn_to_vec (*resultp,
5383                          fixup_symbol_section (arg_sym, objfile),
5384                          block);
5385       found_sym = false;
5386       arg_sym = NULL;
5387     }
5388   else 
5389     {
5390       if (sym->aclass () == LOC_UNRESOLVED)
5391         return true;
5392       else if (sym->is_argument ())
5393         arg_sym = sym;
5394       else
5395         {
5396           found_sym = true;
5397           add_defn_to_vec (*resultp,
5398                            fixup_symbol_section (sym, objfile),
5399                            block);
5400         }
5401     }
5402   return true;
5403 }
5404
5405 /* Helper for add_nonlocal_symbols.  Find symbols in DOMAIN which are
5406    targeted by renamings matching LOOKUP_NAME in BLOCK.  Add these
5407    symbols to RESULT.  Return whether we found such symbols.  */
5408
5409 static int
5410 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5411                          const struct block *block,
5412                          const lookup_name_info &lookup_name,
5413                          domain_enum domain)
5414 {
5415   struct using_direct *renaming;
5416   int defns_mark = result.size ();
5417
5418   symbol_name_matcher_ftype *name_match
5419     = ada_get_symbol_name_matcher (lookup_name);
5420
5421   for (renaming = block_using (block);
5422        renaming != NULL;
5423        renaming = renaming->next)
5424     {
5425       const char *r_name;
5426
5427       /* Avoid infinite recursions: skip this renaming if we are actually
5428          already traversing it.
5429
5430          Currently, symbol lookup in Ada don't use the namespace machinery from
5431          C++/Fortran support: skip namespace imports that use them.  */
5432       if (renaming->searched
5433           || (renaming->import_src != NULL
5434               && renaming->import_src[0] != '\0')
5435           || (renaming->import_dest != NULL
5436               && renaming->import_dest[0] != '\0'))
5437         continue;
5438       renaming->searched = 1;
5439
5440       /* TODO: here, we perform another name-based symbol lookup, which can
5441          pull its own multiple overloads.  In theory, we should be able to do
5442          better in this case since, in DWARF, DW_AT_import is a DIE reference,
5443          not a simple name.  But in order to do this, we would need to enhance
5444          the DWARF reader to associate a symbol to this renaming, instead of a
5445          name.  So, for now, we do something simpler: re-use the C++/Fortran
5446          namespace machinery.  */
5447       r_name = (renaming->alias != NULL
5448                 ? renaming->alias
5449                 : renaming->declaration);
5450       if (name_match (r_name, lookup_name, NULL))
5451         {
5452           lookup_name_info decl_lookup_name (renaming->declaration,
5453                                              lookup_name.match_type ());
5454           ada_add_all_symbols (result, block, decl_lookup_name, domain,
5455                                1, NULL);
5456         }
5457       renaming->searched = 0;
5458     }
5459   return result.size () != defns_mark;
5460 }
5461
5462 /* Implements compare_names, but only applying the comparision using
5463    the given CASING.  */
5464
5465 static int
5466 compare_names_with_case (const char *string1, const char *string2,
5467                          enum case_sensitivity casing)
5468 {
5469   while (*string1 != '\0' && *string2 != '\0')
5470     {
5471       char c1, c2;
5472
5473       if (isspace (*string1) || isspace (*string2))
5474         return strcmp_iw_ordered (string1, string2);
5475
5476       if (casing == case_sensitive_off)
5477         {
5478           c1 = tolower (*string1);
5479           c2 = tolower (*string2);
5480         }
5481       else
5482         {
5483           c1 = *string1;
5484           c2 = *string2;
5485         }
5486       if (c1 != c2)
5487         break;
5488
5489       string1 += 1;
5490       string2 += 1;
5491     }
5492
5493   switch (*string1)
5494     {
5495     case '(':
5496       return strcmp_iw_ordered (string1, string2);
5497     case '_':
5498       if (*string2 == '\0')
5499         {
5500           if (is_name_suffix (string1))
5501             return 0;
5502           else
5503             return 1;
5504         }
5505       /* FALLTHROUGH */
5506     default:
5507       if (*string2 == '(')
5508         return strcmp_iw_ordered (string1, string2);
5509       else
5510         {
5511           if (casing == case_sensitive_off)
5512             return tolower (*string1) - tolower (*string2);
5513           else
5514             return *string1 - *string2;
5515         }
5516     }
5517 }
5518
5519 /* Compare STRING1 to STRING2, with results as for strcmp.
5520    Compatible with strcmp_iw_ordered in that...
5521
5522        strcmp_iw_ordered (STRING1, STRING2) <= 0
5523
5524    ... implies...
5525
5526        compare_names (STRING1, STRING2) <= 0
5527
5528    (they may differ as to what symbols compare equal).  */
5529
5530 static int
5531 compare_names (const char *string1, const char *string2)
5532 {
5533   int result;
5534
5535   /* Similar to what strcmp_iw_ordered does, we need to perform
5536      a case-insensitive comparison first, and only resort to
5537      a second, case-sensitive, comparison if the first one was
5538      not sufficient to differentiate the two strings.  */
5539
5540   result = compare_names_with_case (string1, string2, case_sensitive_off);
5541   if (result == 0)
5542     result = compare_names_with_case (string1, string2, case_sensitive_on);
5543
5544   return result;
5545 }
5546
5547 /* Convenience function to get at the Ada encoded lookup name for
5548    LOOKUP_NAME, as a C string.  */
5549
5550 static const char *
5551 ada_lookup_name (const lookup_name_info &lookup_name)
5552 {
5553   return lookup_name.ada ().lookup_name ().c_str ();
5554 }
5555
5556 /* A helper for add_nonlocal_symbols.  Call expand_matching_symbols
5557    for OBJFILE, then walk the objfile's symtabs and update the
5558    results.  */
5559
5560 static void
5561 map_matching_symbols (struct objfile *objfile,
5562                       const lookup_name_info &lookup_name,
5563                       bool is_wild_match,
5564                       domain_enum domain,
5565                       int global,
5566                       match_data &data)
5567 {
5568   data.objfile = objfile;
5569   objfile->expand_matching_symbols (lookup_name, domain, global,
5570                                     is_wild_match ? nullptr : compare_names);
5571
5572   const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5573   for (compunit_symtab *symtab : objfile->compunits ())
5574     {
5575       const struct block *block
5576         = symtab->blockvector ()->block (block_kind);
5577       if (!iterate_over_symbols_terminated (block, lookup_name,
5578                                             domain, data))
5579         break;
5580     }
5581 }
5582
5583 /* Add to RESULT all non-local symbols whose name and domain match
5584    LOOKUP_NAME and DOMAIN respectively.  The search is performed on
5585    GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5586    symbols otherwise.  */
5587
5588 static void
5589 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5590                       const lookup_name_info &lookup_name,
5591                       domain_enum domain, int global)
5592 {
5593   struct match_data data (&result);
5594
5595   bool is_wild_match = lookup_name.ada ().wild_match_p ();
5596
5597   for (objfile *objfile : current_program_space->objfiles ())
5598     {
5599       map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5600                             global, data);
5601
5602       for (compunit_symtab *cu : objfile->compunits ())
5603         {
5604           const struct block *global_block
5605             = cu->blockvector ()->global_block ();
5606
5607           if (ada_add_block_renamings (result, global_block, lookup_name,
5608                                        domain))
5609             data.found_sym = true;
5610         }
5611     }
5612
5613   if (result.empty () && global && !is_wild_match)
5614     {
5615       const char *name = ada_lookup_name (lookup_name);
5616       std::string bracket_name = std::string ("<_ada_") + name + '>';
5617       lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5618
5619       for (objfile *objfile : current_program_space->objfiles ())
5620         map_matching_symbols (objfile, name1, false, domain, global, data);
5621     }
5622 }
5623
5624 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5625    FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5626    returning the number of matches.  Add these to RESULT.
5627
5628    When FULL_SEARCH is non-zero, any non-function/non-enumeral
5629    symbol match within the nest of blocks whose innermost member is BLOCK,
5630    is the one match returned (no other matches in that or
5631    enclosing blocks is returned).  If there are any matches in or
5632    surrounding BLOCK, then these alone are returned.
5633
5634    Names prefixed with "standard__" are handled specially:
5635    "standard__" is first stripped off (by the lookup_name
5636    constructor), and only static and global symbols are searched.
5637
5638    If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5639    to lookup global symbols.  */
5640
5641 static void
5642 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5643                      const struct block *block,
5644                      const lookup_name_info &lookup_name,
5645                      domain_enum domain,
5646                      int full_search,
5647                      int *made_global_lookup_p)
5648 {
5649   struct symbol *sym;
5650
5651   if (made_global_lookup_p)
5652     *made_global_lookup_p = 0;
5653
5654   /* Special case: If the user specifies a symbol name inside package
5655      Standard, do a non-wild matching of the symbol name without
5656      the "standard__" prefix.  This was primarily introduced in order
5657      to allow the user to specifically access the standard exceptions
5658      using, for instance, Standard.Constraint_Error when Constraint_Error
5659      is ambiguous (due to the user defining its own Constraint_Error
5660      entity inside its program).  */
5661   if (lookup_name.ada ().standard_p ())
5662     block = NULL;
5663
5664   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
5665
5666   if (block != NULL)
5667     {
5668       if (full_search)
5669         ada_add_local_symbols (result, lookup_name, block, domain);
5670       else
5671         {
5672           /* In the !full_search case we're are being called by
5673              iterate_over_symbols, and we don't want to search
5674              superblocks.  */
5675           ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5676         }
5677       if (!result.empty () || !full_search)
5678         return;
5679     }
5680
5681   /* No non-global symbols found.  Check our cache to see if we have
5682      already performed this search before.  If we have, then return
5683      the same result.  */
5684
5685   if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5686                             domain, &sym, &block))
5687     {
5688       if (sym != NULL)
5689         add_defn_to_vec (result, sym, block);
5690       return;
5691     }
5692
5693   if (made_global_lookup_p)
5694     *made_global_lookup_p = 1;
5695
5696   /* Search symbols from all global blocks.  */
5697  
5698   add_nonlocal_symbols (result, lookup_name, domain, 1);
5699
5700   /* Now add symbols from all per-file blocks if we've gotten no hits
5701      (not strictly correct, but perhaps better than an error).  */
5702
5703   if (result.empty ())
5704     add_nonlocal_symbols (result, lookup_name, domain, 0);
5705 }
5706
5707 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5708    is non-zero, enclosing scope and in global scopes.
5709
5710    Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5711    blocks and symbol tables (if any) in which they were found.
5712
5713    When full_search is non-zero, any non-function/non-enumeral
5714    symbol match within the nest of blocks whose innermost member is BLOCK,
5715    is the one match returned (no other matches in that or
5716    enclosing blocks is returned).  If there are any matches in or
5717    surrounding BLOCK, then these alone are returned.
5718
5719    Names prefixed with "standard__" are handled specially: "standard__"
5720    is first stripped off, and only static and global symbols are searched.  */
5721
5722 static std::vector<struct block_symbol>
5723 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5724                                const struct block *block,
5725                                domain_enum domain,
5726                                int full_search)
5727 {
5728   int syms_from_global_search;
5729   std::vector<struct block_symbol> results;
5730
5731   ada_add_all_symbols (results, block, lookup_name,
5732                        domain, full_search, &syms_from_global_search);
5733
5734   remove_extra_symbols (&results);
5735
5736   if (results.empty () && full_search && syms_from_global_search)
5737     cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5738
5739   if (results.size () == 1 && full_search && syms_from_global_search)
5740     cache_symbol (ada_lookup_name (lookup_name), domain,
5741                   results[0].symbol, results[0].block);
5742
5743   remove_irrelevant_renamings (&results, block);
5744   return results;
5745 }
5746
5747 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5748    in global scopes, returning (SYM,BLOCK) tuples.
5749
5750    See ada_lookup_symbol_list_worker for further details.  */
5751
5752 std::vector<struct block_symbol>
5753 ada_lookup_symbol_list (const char *name, const struct block *block,
5754                         domain_enum domain)
5755 {
5756   symbol_name_match_type name_match_type = name_match_type_from_name (name);
5757   lookup_name_info lookup_name (name, name_match_type);
5758
5759   return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5760 }
5761
5762 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5763    to 1, but choosing the first symbol found if there are multiple
5764    choices.
5765
5766    The result is stored in *INFO, which must be non-NULL.
5767    If no match is found, INFO->SYM is set to NULL.  */
5768
5769 void
5770 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5771                            domain_enum domain,
5772                            struct block_symbol *info)
5773 {
5774   /* Since we already have an encoded name, wrap it in '<>' to force a
5775      verbatim match.  Otherwise, if the name happens to not look like
5776      an encoded name (because it doesn't include a "__"),
5777      ada_lookup_name_info would re-encode/fold it again, and that
5778      would e.g., incorrectly lowercase object renaming names like
5779      "R28b" -> "r28b".  */
5780   std::string verbatim = add_angle_brackets (name);
5781
5782   gdb_assert (info != NULL);
5783   *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5784 }
5785
5786 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5787    scope and in global scopes, or NULL if none.  NAME is folded and
5788    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
5789    choosing the first symbol if there are multiple choices.  */
5790
5791 struct block_symbol
5792 ada_lookup_symbol (const char *name, const struct block *block0,
5793                    domain_enum domain)
5794 {
5795   std::vector<struct block_symbol> candidates
5796     = ada_lookup_symbol_list (name, block0, domain);
5797
5798   if (candidates.empty ())
5799     return {};
5800
5801   block_symbol info = candidates[0];
5802   info.symbol = fixup_symbol_section (info.symbol, NULL);
5803   return info;
5804 }
5805
5806
5807 /* True iff STR is a possible encoded suffix of a normal Ada name
5808    that is to be ignored for matching purposes.  Suffixes of parallel
5809    names (e.g., XVE) are not included here.  Currently, the possible suffixes
5810    are given by any of the regular expressions:
5811
5812    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
5813    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
5814    TKB              [subprogram suffix for task bodies]
5815    _E[0-9]+[bs]$    [protected object entry suffixes]
5816    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5817
5818    Also, any leading "__[0-9]+" sequence is skipped before the suffix
5819    match is performed.  This sequence is used to differentiate homonyms,
5820    is an optional part of a valid name suffix.  */
5821
5822 static int
5823 is_name_suffix (const char *str)
5824 {
5825   int k;
5826   const char *matching;
5827   const int len = strlen (str);
5828
5829   /* Skip optional leading __[0-9]+.  */
5830
5831   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5832     {
5833       str += 3;
5834       while (isdigit (str[0]))
5835         str += 1;
5836     }
5837   
5838   /* [.$][0-9]+ */
5839
5840   if (str[0] == '.' || str[0] == '$')
5841     {
5842       matching = str + 1;
5843       while (isdigit (matching[0]))
5844         matching += 1;
5845       if (matching[0] == '\0')
5846         return 1;
5847     }
5848
5849   /* ___[0-9]+ */
5850
5851   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5852     {
5853       matching = str + 3;
5854       while (isdigit (matching[0]))
5855         matching += 1;
5856       if (matching[0] == '\0')
5857         return 1;
5858     }
5859
5860   /* "TKB" suffixes are used for subprograms implementing task bodies.  */
5861
5862   if (strcmp (str, "TKB") == 0)
5863     return 1;
5864
5865 #if 0
5866   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5867      with a N at the end.  Unfortunately, the compiler uses the same
5868      convention for other internal types it creates.  So treating
5869      all entity names that end with an "N" as a name suffix causes
5870      some regressions.  For instance, consider the case of an enumerated
5871      type.  To support the 'Image attribute, it creates an array whose
5872      name ends with N.
5873      Having a single character like this as a suffix carrying some
5874      information is a bit risky.  Perhaps we should change the encoding
5875      to be something like "_N" instead.  In the meantime, do not do
5876      the following check.  */
5877   /* Protected Object Subprograms */
5878   if (len == 1 && str [0] == 'N')
5879     return 1;
5880 #endif
5881
5882   /* _E[0-9]+[bs]$ */
5883   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5884     {
5885       matching = str + 3;
5886       while (isdigit (matching[0]))
5887         matching += 1;
5888       if ((matching[0] == 'b' || matching[0] == 's')
5889           && matching [1] == '\0')
5890         return 1;
5891     }
5892
5893   /* ??? We should not modify STR directly, as we are doing below.  This
5894      is fine in this case, but may become problematic later if we find
5895      that this alternative did not work, and want to try matching
5896      another one from the begining of STR.  Since we modified it, we
5897      won't be able to find the begining of the string anymore!  */
5898   if (str[0] == 'X')
5899     {
5900       str += 1;
5901       while (str[0] != '_' && str[0] != '\0')
5902         {
5903           if (str[0] != 'n' && str[0] != 'b')
5904             return 0;
5905           str += 1;
5906         }
5907     }
5908
5909   if (str[0] == '\000')
5910     return 1;
5911
5912   if (str[0] == '_')
5913     {
5914       if (str[1] != '_' || str[2] == '\000')
5915         return 0;
5916       if (str[2] == '_')
5917         {
5918           if (strcmp (str + 3, "JM") == 0)
5919             return 1;
5920           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5921              the LJM suffix in favor of the JM one.  But we will
5922              still accept LJM as a valid suffix for a reasonable
5923              amount of time, just to allow ourselves to debug programs
5924              compiled using an older version of GNAT.  */
5925           if (strcmp (str + 3, "LJM") == 0)
5926             return 1;
5927           if (str[3] != 'X')
5928             return 0;
5929           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5930               || str[4] == 'U' || str[4] == 'P')
5931             return 1;
5932           if (str[4] == 'R' && str[5] != 'T')
5933             return 1;
5934           return 0;
5935         }
5936       if (!isdigit (str[2]))
5937         return 0;
5938       for (k = 3; str[k] != '\0'; k += 1)
5939         if (!isdigit (str[k]) && str[k] != '_')
5940           return 0;
5941       return 1;
5942     }
5943   if (str[0] == '$' && isdigit (str[1]))
5944     {
5945       for (k = 2; str[k] != '\0'; k += 1)
5946         if (!isdigit (str[k]) && str[k] != '_')
5947           return 0;
5948       return 1;
5949     }
5950   return 0;
5951 }
5952
5953 /* Return non-zero if the string starting at NAME and ending before
5954    NAME_END contains no capital letters.  */
5955
5956 static int
5957 is_valid_name_for_wild_match (const char *name0)
5958 {
5959   std::string decoded_name = ada_decode (name0);
5960   int i;
5961
5962   /* If the decoded name starts with an angle bracket, it means that
5963      NAME0 does not follow the GNAT encoding format.  It should then
5964      not be allowed as a possible wild match.  */
5965   if (decoded_name[0] == '<')
5966     return 0;
5967
5968   for (i=0; decoded_name[i] != '\0'; i++)
5969     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5970       return 0;
5971
5972   return 1;
5973 }
5974
5975 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5976    character which could start a simple name.  Assumes that *NAMEP points
5977    somewhere inside the string beginning at NAME0.  */
5978
5979 static int
5980 advance_wild_match (const char **namep, const char *name0, char target0)
5981 {
5982   const char *name = *namep;
5983
5984   while (1)
5985     {
5986       char t0, t1;
5987
5988       t0 = *name;
5989       if (t0 == '_')
5990         {
5991           t1 = name[1];
5992           if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5993             {
5994               name += 1;
5995               if (name == name0 + 5 && startswith (name0, "_ada"))
5996                 break;
5997               else
5998                 name += 1;
5999             }
6000           else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6001                                  || name[2] == target0))
6002             {
6003               name += 2;
6004               break;
6005             }
6006           else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
6007             {
6008               /* Names like "pkg__B_N__name", where N is a number, are
6009                  block-local.  We can handle these by simply skipping
6010                  the "B_" here.  */
6011               name += 4;
6012             }
6013           else
6014             return 0;
6015         }
6016       else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6017         name += 1;
6018       else
6019         return 0;
6020     }
6021
6022   *namep = name;
6023   return 1;
6024 }
6025
6026 /* Return true iff NAME encodes a name of the form prefix.PATN.
6027    Ignores any informational suffixes of NAME (i.e., for which
6028    is_name_suffix is true).  Assumes that PATN is a lower-cased Ada
6029    simple name.  */
6030
6031 static bool
6032 wild_match (const char *name, const char *patn)
6033 {
6034   const char *p;
6035   const char *name0 = name;
6036
6037   if (startswith (name, "___ghost_"))
6038     name += 9;
6039
6040   while (1)
6041     {
6042       const char *match = name;
6043
6044       if (*name == *patn)
6045         {
6046           for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6047             if (*p != *name)
6048               break;
6049           if (*p == '\0' && is_name_suffix (name))
6050             return match == name0 || is_valid_name_for_wild_match (name0);
6051
6052           if (name[-1] == '_')
6053             name -= 1;
6054         }
6055       if (!advance_wild_match (&name, name0, *patn))
6056         return false;
6057     }
6058 }
6059
6060 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
6061    necessary).  OBJFILE is the section containing BLOCK.  */
6062
6063 static void
6064 ada_add_block_symbols (std::vector<struct block_symbol> &result,
6065                        const struct block *block,
6066                        const lookup_name_info &lookup_name,
6067                        domain_enum domain, struct objfile *objfile)
6068 {
6069   struct block_iterator iter;
6070   /* A matching argument symbol, if any.  */
6071   struct symbol *arg_sym;
6072   /* Set true when we find a matching non-argument symbol.  */
6073   bool found_sym;
6074   struct symbol *sym;
6075
6076   arg_sym = NULL;
6077   found_sym = false;
6078   for (sym = block_iter_match_first (block, lookup_name, &iter);
6079        sym != NULL;
6080        sym = block_iter_match_next (lookup_name, &iter))
6081     {
6082       if (symbol_matches_domain (sym->language (), sym->domain (), domain))
6083         {
6084           if (sym->aclass () != LOC_UNRESOLVED)
6085             {
6086               if (sym->is_argument ())
6087                 arg_sym = sym;
6088               else
6089                 {
6090                   found_sym = true;
6091                   add_defn_to_vec (result,
6092                                    fixup_symbol_section (sym, objfile),
6093                                    block);
6094                 }
6095             }
6096         }
6097     }
6098
6099   /* Handle renamings.  */
6100
6101   if (ada_add_block_renamings (result, block, lookup_name, domain))
6102     found_sym = true;
6103
6104   if (!found_sym && arg_sym != NULL)
6105     {
6106       add_defn_to_vec (result,
6107                        fixup_symbol_section (arg_sym, objfile),
6108                        block);
6109     }
6110
6111   if (!lookup_name.ada ().wild_match_p ())
6112     {
6113       arg_sym = NULL;
6114       found_sym = false;
6115       const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6116       const char *name = ada_lookup_name.c_str ();
6117       size_t name_len = ada_lookup_name.size ();
6118
6119       ALL_BLOCK_SYMBOLS (block, iter, sym)
6120       {
6121         if (symbol_matches_domain (sym->language (),
6122                                    sym->domain (), domain))
6123           {
6124             int cmp;
6125
6126             cmp = (int) '_' - (int) sym->linkage_name ()[0];
6127             if (cmp == 0)
6128               {
6129                 cmp = !startswith (sym->linkage_name (), "_ada_");
6130                 if (cmp == 0)
6131                   cmp = strncmp (name, sym->linkage_name () + 5,
6132                                  name_len);
6133               }
6134
6135             if (cmp == 0
6136                 && is_name_suffix (sym->linkage_name () + name_len + 5))
6137               {
6138                 if (sym->aclass () != LOC_UNRESOLVED)
6139                   {
6140                     if (sym->is_argument ())
6141                       arg_sym = sym;
6142                     else
6143                       {
6144                         found_sym = true;
6145                         add_defn_to_vec (result,
6146                                          fixup_symbol_section (sym, objfile),
6147                                          block);
6148                       }
6149                   }
6150               }
6151           }
6152       }
6153
6154       /* NOTE: This really shouldn't be needed for _ada_ symbols.
6155          They aren't parameters, right?  */
6156       if (!found_sym && arg_sym != NULL)
6157         {
6158           add_defn_to_vec (result,
6159                            fixup_symbol_section (arg_sym, objfile),
6160                            block);
6161         }
6162     }
6163 }
6164 \f
6165
6166                                 /* Symbol Completion */
6167
6168 /* See symtab.h.  */
6169
6170 bool
6171 ada_lookup_name_info::matches
6172   (const char *sym_name,
6173    symbol_name_match_type match_type,
6174    completion_match_result *comp_match_res) const
6175 {
6176   bool match = false;
6177   const char *text = m_encoded_name.c_str ();
6178   size_t text_len = m_encoded_name.size ();
6179
6180   /* First, test against the fully qualified name of the symbol.  */
6181
6182   if (strncmp (sym_name, text, text_len) == 0)
6183     match = true;
6184
6185   std::string decoded_name = ada_decode (sym_name);
6186   if (match && !m_encoded_p)
6187     {
6188       /* One needed check before declaring a positive match is to verify
6189          that iff we are doing a verbatim match, the decoded version
6190          of the symbol name starts with '<'.  Otherwise, this symbol name
6191          is not a suitable completion.  */
6192
6193       bool has_angle_bracket = (decoded_name[0] == '<');
6194       match = (has_angle_bracket == m_verbatim_p);
6195     }
6196
6197   if (match && !m_verbatim_p)
6198     {
6199       /* When doing non-verbatim match, another check that needs to
6200          be done is to verify that the potentially matching symbol name
6201          does not include capital letters, because the ada-mode would
6202          not be able to understand these symbol names without the
6203          angle bracket notation.  */
6204       const char *tmp;
6205
6206       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6207       if (*tmp != '\0')
6208         match = false;
6209     }
6210
6211   /* Second: Try wild matching...  */
6212
6213   if (!match && m_wild_match_p)
6214     {
6215       /* Since we are doing wild matching, this means that TEXT
6216          may represent an unqualified symbol name.  We therefore must
6217          also compare TEXT against the unqualified name of the symbol.  */
6218       sym_name = ada_unqualified_name (decoded_name.c_str ());
6219
6220       if (strncmp (sym_name, text, text_len) == 0)
6221         match = true;
6222     }
6223
6224   /* Finally: If we found a match, prepare the result to return.  */
6225
6226   if (!match)
6227     return false;
6228
6229   if (comp_match_res != NULL)
6230     {
6231       std::string &match_str = comp_match_res->match.storage ();
6232
6233       if (!m_encoded_p)
6234         match_str = ada_decode (sym_name);
6235       else
6236         {
6237           if (m_verbatim_p)
6238             match_str = add_angle_brackets (sym_name);
6239           else
6240             match_str = sym_name;
6241
6242         }
6243
6244       comp_match_res->set_match (match_str.c_str ());
6245     }
6246
6247   return true;
6248 }
6249
6250                                 /* Field Access */
6251
6252 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6253    for tagged types.  */
6254
6255 static int
6256 ada_is_dispatch_table_ptr_type (struct type *type)
6257 {
6258   const char *name;
6259
6260   if (type->code () != TYPE_CODE_PTR)
6261     return 0;
6262
6263   name = type->target_type ()->name ();
6264   if (name == NULL)
6265     return 0;
6266
6267   return (strcmp (name, "ada__tags__dispatch_table") == 0);
6268 }
6269
6270 /* Return non-zero if TYPE is an interface tag.  */
6271
6272 static int
6273 ada_is_interface_tag (struct type *type)
6274 {
6275   const char *name = type->name ();
6276
6277   if (name == NULL)
6278     return 0;
6279
6280   return (strcmp (name, "ada__tags__interface_tag") == 0);
6281 }
6282
6283 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6284    to be invisible to users.  */
6285
6286 int
6287 ada_is_ignored_field (struct type *type, int field_num)
6288 {
6289   if (field_num < 0 || field_num > type->num_fields ())
6290     return 1;
6291
6292   /* Check the name of that field.  */
6293   {
6294     const char *name = type->field (field_num).name ();
6295
6296     /* Anonymous field names should not be printed.
6297        brobecker/2007-02-20: I don't think this can actually happen
6298        but we don't want to print the value of anonymous fields anyway.  */
6299     if (name == NULL)
6300       return 1;
6301
6302     /* Normally, fields whose name start with an underscore ("_")
6303        are fields that have been internally generated by the compiler,
6304        and thus should not be printed.  The "_parent" field is special,
6305        however: This is a field internally generated by the compiler
6306        for tagged types, and it contains the components inherited from
6307        the parent type.  This field should not be printed as is, but
6308        should not be ignored either.  */
6309     if (name[0] == '_' && !startswith (name, "_parent"))
6310       return 1;
6311
6312     /* The compiler doesn't document this, but sometimes it emits
6313        a field whose name starts with a capital letter, like 'V148s'.
6314        These aren't marked as artificial in any way, but we know they
6315        should be ignored.  However, wrapper fields should not be
6316        ignored.  */
6317     if (name[0] == 'S' || name[0] == 'R' || name[0] == 'O')
6318       {
6319         /* Wrapper field.  */
6320       }
6321     else if (isupper (name[0]))
6322       return 1;
6323   }
6324
6325   /* If this is the dispatch table of a tagged type or an interface tag,
6326      then ignore.  */
6327   if (ada_is_tagged_type (type, 1)
6328       && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
6329           || ada_is_interface_tag (type->field (field_num).type ())))
6330     return 1;
6331
6332   /* Not a special field, so it should not be ignored.  */
6333   return 0;
6334 }
6335
6336 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
6337    pointer or reference type whose ultimate target has a tag field.  */
6338
6339 int
6340 ada_is_tagged_type (struct type *type, int refok)
6341 {
6342   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6343 }
6344
6345 /* True iff TYPE represents the type of X'Tag */
6346
6347 int
6348 ada_is_tag_type (struct type *type)
6349 {
6350   type = ada_check_typedef (type);
6351
6352   if (type == NULL || type->code () != TYPE_CODE_PTR)
6353     return 0;
6354   else
6355     {
6356       const char *name = ada_type_name (type->target_type ());
6357
6358       return (name != NULL
6359               && strcmp (name, "ada__tags__dispatch_table") == 0);
6360     }
6361 }
6362
6363 /* The type of the tag on VAL.  */
6364
6365 static struct type *
6366 ada_tag_type (struct value *val)
6367 {
6368   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6369 }
6370
6371 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6372    retired at Ada 05).  */
6373
6374 static int
6375 is_ada95_tag (struct value *tag)
6376 {
6377   return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6378 }
6379
6380 /* The value of the tag on VAL.  */
6381
6382 static struct value *
6383 ada_value_tag (struct value *val)
6384 {
6385   return ada_value_struct_elt (val, "_tag", 0);
6386 }
6387
6388 /* The value of the tag on the object of type TYPE whose contents are
6389    saved at VALADDR, if it is non-null, or is at memory address
6390    ADDRESS.  */
6391
6392 static struct value *
6393 value_tag_from_contents_and_address (struct type *type,
6394                                      const gdb_byte *valaddr,
6395                                      CORE_ADDR address)
6396 {
6397   int tag_byte_offset;
6398   struct type *tag_type;
6399
6400   gdb::array_view<const gdb_byte> contents;
6401   if (valaddr != nullptr)
6402     contents = gdb::make_array_view (valaddr, type->length ());
6403   struct type *resolved_type = resolve_dynamic_type (type, contents, address);
6404   if (find_struct_field ("_tag", resolved_type, 0, &tag_type, &tag_byte_offset,
6405                          NULL, NULL, NULL))
6406     {
6407       const gdb_byte *valaddr1 = ((valaddr == NULL)
6408                                   ? NULL
6409                                   : valaddr + tag_byte_offset);
6410       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6411
6412       return value_from_contents_and_address (tag_type, valaddr1, address1);
6413     }
6414   return NULL;
6415 }
6416
6417 static struct type *
6418 type_from_tag (struct value *tag)
6419 {
6420   gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6421
6422   if (type_name != NULL)
6423     return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6424   return NULL;
6425 }
6426
6427 /* Given a value OBJ of a tagged type, return a value of this
6428    type at the base address of the object.  The base address, as
6429    defined in Ada.Tags, it is the address of the primary tag of
6430    the object, and therefore where the field values of its full
6431    view can be fetched.  */
6432
6433 struct value *
6434 ada_tag_value_at_base_address (struct value *obj)
6435 {
6436   struct value *val;
6437   LONGEST offset_to_top = 0;
6438   struct type *ptr_type, *obj_type;
6439   struct value *tag;
6440   CORE_ADDR base_address;
6441
6442   obj_type = value_type (obj);
6443
6444   /* It is the responsability of the caller to deref pointers.  */
6445
6446   if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6447     return obj;
6448
6449   tag = ada_value_tag (obj);
6450   if (!tag)
6451     return obj;
6452
6453   /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
6454
6455   if (is_ada95_tag (tag))
6456     return obj;
6457
6458   struct type *offset_type
6459     = language_lookup_primitive_type (language_def (language_ada),
6460                                       target_gdbarch(), "storage_offset");
6461   ptr_type = lookup_pointer_type (offset_type);
6462   val = value_cast (ptr_type, tag);
6463   if (!val)
6464     return obj;
6465
6466   /* It is perfectly possible that an exception be raised while
6467      trying to determine the base address, just like for the tag;
6468      see ada_tag_name for more details.  We do not print the error
6469      message for the same reason.  */
6470
6471   try
6472     {
6473       offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6474     }
6475
6476   catch (const gdb_exception_error &e)
6477     {
6478       return obj;
6479     }
6480
6481   /* If offset is null, nothing to do.  */
6482
6483   if (offset_to_top == 0)
6484     return obj;
6485
6486   /* -1 is a special case in Ada.Tags; however, what should be done
6487      is not quite clear from the documentation.  So do nothing for
6488      now.  */
6489
6490   if (offset_to_top == -1)
6491     return obj;
6492
6493   /* Storage_Offset'Last is used to indicate that a dynamic offset to
6494      top is used.  In this situation the offset is stored just after
6495      the tag, in the object itself.  */
6496   ULONGEST last = (((ULONGEST) 1) << (8 * offset_type->length () - 1)) - 1;
6497   if (offset_to_top == last)
6498     {
6499       struct value *tem = value_addr (tag);
6500       tem = value_ptradd (tem, 1);
6501       tem = value_cast (ptr_type, tem);
6502       offset_to_top = value_as_long (value_ind (tem));
6503     }
6504
6505   if (offset_to_top > 0)
6506     {
6507       /* OFFSET_TO_TOP used to be a positive value to be subtracted
6508          from the base address.  This was however incompatible with
6509          C++ dispatch table: C++ uses a *negative* value to *add*
6510          to the base address.  Ada's convention has therefore been
6511          changed in GNAT 19.0w 20171023: since then, C++ and Ada
6512          use the same convention.  Here, we support both cases by
6513          checking the sign of OFFSET_TO_TOP.  */
6514       offset_to_top = -offset_to_top;
6515     }
6516
6517   base_address = value_address (obj) + offset_to_top;
6518   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6519
6520   /* Make sure that we have a proper tag at the new address.
6521      Otherwise, offset_to_top is bogus (which can happen when
6522      the object is not initialized yet).  */
6523
6524   if (!tag)
6525     return obj;
6526
6527   obj_type = type_from_tag (tag);
6528
6529   if (!obj_type)
6530     return obj;
6531
6532   return value_from_contents_and_address (obj_type, NULL, base_address);
6533 }
6534
6535 /* Return the "ada__tags__type_specific_data" type.  */
6536
6537 static struct type *
6538 ada_get_tsd_type (struct inferior *inf)
6539 {
6540   struct ada_inferior_data *data = get_ada_inferior_data (inf);
6541
6542   if (data->tsd_type == 0)
6543     data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6544   return data->tsd_type;
6545 }
6546
6547 /* Return the TSD (type-specific data) associated to the given TAG.
6548    TAG is assumed to be the tag of a tagged-type entity.
6549
6550    May return NULL if we are unable to get the TSD.  */
6551
6552 static struct value *
6553 ada_get_tsd_from_tag (struct value *tag)
6554 {
6555   struct value *val;
6556   struct type *type;
6557
6558   /* First option: The TSD is simply stored as a field of our TAG.
6559      Only older versions of GNAT would use this format, but we have
6560      to test it first, because there are no visible markers for
6561      the current approach except the absence of that field.  */
6562
6563   val = ada_value_struct_elt (tag, "tsd", 1);
6564   if (val)
6565     return val;
6566
6567   /* Try the second representation for the dispatch table (in which
6568      there is no explicit 'tsd' field in the referent of the tag pointer,
6569      and instead the tsd pointer is stored just before the dispatch
6570      table.  */
6571
6572   type = ada_get_tsd_type (current_inferior());
6573   if (type == NULL)
6574     return NULL;
6575   type = lookup_pointer_type (lookup_pointer_type (type));
6576   val = value_cast (type, tag);
6577   if (val == NULL)
6578     return NULL;
6579   return value_ind (value_ptradd (val, -1));
6580 }
6581
6582 /* Given the TSD of a tag (type-specific data), return a string
6583    containing the name of the associated type.
6584
6585    May return NULL if we are unable to determine the tag name.  */
6586
6587 static gdb::unique_xmalloc_ptr<char>
6588 ada_tag_name_from_tsd (struct value *tsd)
6589 {
6590   struct value *val;
6591
6592   val = ada_value_struct_elt (tsd, "expanded_name", 1);
6593   if (val == NULL)
6594     return NULL;
6595   gdb::unique_xmalloc_ptr<char> buffer
6596     = target_read_string (value_as_address (val), INT_MAX);
6597   if (buffer == nullptr)
6598     return nullptr;
6599
6600   try
6601     {
6602       /* Let this throw an exception on error.  If the data is
6603          uninitialized, we'd rather not have the user see a
6604          warning.  */
6605       const char *folded = ada_fold_name (buffer.get (), true);
6606       return make_unique_xstrdup (folded);
6607     }
6608   catch (const gdb_exception &)
6609     {
6610       return nullptr;
6611     }
6612 }
6613
6614 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6615    a C string.
6616
6617    Return NULL if the TAG is not an Ada tag, or if we were unable to
6618    determine the name of that tag.  */
6619
6620 gdb::unique_xmalloc_ptr<char>
6621 ada_tag_name (struct value *tag)
6622 {
6623   gdb::unique_xmalloc_ptr<char> name;
6624
6625   if (!ada_is_tag_type (value_type (tag)))
6626     return NULL;
6627
6628   /* It is perfectly possible that an exception be raised while trying
6629      to determine the TAG's name, even under normal circumstances:
6630      The associated variable may be uninitialized or corrupted, for
6631      instance. We do not let any exception propagate past this point.
6632      instead we return NULL.
6633
6634      We also do not print the error message either (which often is very
6635      low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6636      the caller print a more meaningful message if necessary.  */
6637   try
6638     {
6639       struct value *tsd = ada_get_tsd_from_tag (tag);
6640
6641       if (tsd != NULL)
6642         name = ada_tag_name_from_tsd (tsd);
6643     }
6644   catch (const gdb_exception_error &e)
6645     {
6646     }
6647
6648   return name;
6649 }
6650
6651 /* The parent type of TYPE, or NULL if none.  */
6652
6653 struct type *
6654 ada_parent_type (struct type *type)
6655 {
6656   int i;
6657
6658   type = ada_check_typedef (type);
6659
6660   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6661     return NULL;
6662
6663   for (i = 0; i < type->num_fields (); i += 1)
6664     if (ada_is_parent_field (type, i))
6665       {
6666         struct type *parent_type = type->field (i).type ();
6667
6668         /* If the _parent field is a pointer, then dereference it.  */
6669         if (parent_type->code () == TYPE_CODE_PTR)
6670           parent_type = parent_type->target_type ();
6671         /* If there is a parallel XVS type, get the actual base type.  */
6672         parent_type = ada_get_base_type (parent_type);
6673
6674         return ada_check_typedef (parent_type);
6675       }
6676
6677   return NULL;
6678 }
6679
6680 /* True iff field number FIELD_NUM of structure type TYPE contains the
6681    parent-type (inherited) fields of a derived type.  Assumes TYPE is
6682    a structure type with at least FIELD_NUM+1 fields.  */
6683
6684 int
6685 ada_is_parent_field (struct type *type, int field_num)
6686 {
6687   const char *name = ada_check_typedef (type)->field (field_num).name ();
6688
6689   return (name != NULL
6690           && (startswith (name, "PARENT")
6691               || startswith (name, "_parent")));
6692 }
6693
6694 /* True iff field number FIELD_NUM of structure type TYPE is a
6695    transparent wrapper field (which should be silently traversed when doing
6696    field selection and flattened when printing).  Assumes TYPE is a
6697    structure type with at least FIELD_NUM+1 fields.  Such fields are always
6698    structures.  */
6699
6700 int
6701 ada_is_wrapper_field (struct type *type, int field_num)
6702 {
6703   const char *name = type->field (field_num).name ();
6704
6705   if (name != NULL && strcmp (name, "RETVAL") == 0)
6706     {
6707       /* This happens in functions with "out" or "in out" parameters
6708          which are passed by copy.  For such functions, GNAT describes
6709          the function's return type as being a struct where the return
6710          value is in a field called RETVAL, and where the other "out"
6711          or "in out" parameters are fields of that struct.  This is not
6712          a wrapper.  */
6713       return 0;
6714     }
6715
6716   return (name != NULL
6717           && (startswith (name, "PARENT")
6718               || strcmp (name, "REP") == 0
6719               || startswith (name, "_parent")
6720               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6721 }
6722
6723 /* True iff field number FIELD_NUM of structure or union type TYPE
6724    is a variant wrapper.  Assumes TYPE is a structure type with at least
6725    FIELD_NUM+1 fields.  */
6726
6727 int
6728 ada_is_variant_part (struct type *type, int field_num)
6729 {
6730   /* Only Ada types are eligible.  */
6731   if (!ADA_TYPE_P (type))
6732     return 0;
6733
6734   struct type *field_type = type->field (field_num).type ();
6735
6736   return (field_type->code () == TYPE_CODE_UNION
6737           || (is_dynamic_field (type, field_num)
6738               && (field_type->target_type ()->code ()
6739                   == TYPE_CODE_UNION)));
6740 }
6741
6742 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6743    whose discriminants are contained in the record type OUTER_TYPE,
6744    returns the type of the controlling discriminant for the variant.
6745    May return NULL if the type could not be found.  */
6746
6747 struct type *
6748 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6749 {
6750   const char *name = ada_variant_discrim_name (var_type);
6751
6752   return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6753 }
6754
6755 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6756    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6757    represents a 'when others' clause; otherwise 0.  */
6758
6759 static int
6760 ada_is_others_clause (struct type *type, int field_num)
6761 {
6762   const char *name = type->field (field_num).name ();
6763
6764   return (name != NULL && name[0] == 'O');
6765 }
6766
6767 /* Assuming that TYPE0 is the type of the variant part of a record,
6768    returns the name of the discriminant controlling the variant.
6769    The value is valid until the next call to ada_variant_discrim_name.  */
6770
6771 const char *
6772 ada_variant_discrim_name (struct type *type0)
6773 {
6774   static std::string result;
6775   struct type *type;
6776   const char *name;
6777   const char *discrim_end;
6778   const char *discrim_start;
6779
6780   if (type0->code () == TYPE_CODE_PTR)
6781     type = type0->target_type ();
6782   else
6783     type = type0;
6784
6785   name = ada_type_name (type);
6786
6787   if (name == NULL || name[0] == '\000')
6788     return "";
6789
6790   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6791        discrim_end -= 1)
6792     {
6793       if (startswith (discrim_end, "___XVN"))
6794         break;
6795     }
6796   if (discrim_end == name)
6797     return "";
6798
6799   for (discrim_start = discrim_end; discrim_start != name + 3;
6800        discrim_start -= 1)
6801     {
6802       if (discrim_start == name + 1)
6803         return "";
6804       if ((discrim_start > name + 3
6805            && startswith (discrim_start - 3, "___"))
6806           || discrim_start[-1] == '.')
6807         break;
6808     }
6809
6810   result = std::string (discrim_start, discrim_end - discrim_start);
6811   return result.c_str ();
6812 }
6813
6814 /* Scan STR for a subtype-encoded number, beginning at position K.
6815    Put the position of the character just past the number scanned in
6816    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
6817    Return 1 if there was a valid number at the given position, and 0
6818    otherwise.  A "subtype-encoded" number consists of the absolute value
6819    in decimal, followed by the letter 'm' to indicate a negative number.
6820    Assumes 0m does not occur.  */
6821
6822 int
6823 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6824 {
6825   ULONGEST RU;
6826
6827   if (!isdigit (str[k]))
6828     return 0;
6829
6830   /* Do it the hard way so as not to make any assumption about
6831      the relationship of unsigned long (%lu scan format code) and
6832      LONGEST.  */
6833   RU = 0;
6834   while (isdigit (str[k]))
6835     {
6836       RU = RU * 10 + (str[k] - '0');
6837       k += 1;
6838     }
6839
6840   if (str[k] == 'm')
6841     {
6842       if (R != NULL)
6843         *R = (-(LONGEST) (RU - 1)) - 1;
6844       k += 1;
6845     }
6846   else if (R != NULL)
6847     *R = (LONGEST) RU;
6848
6849   /* NOTE on the above: Technically, C does not say what the results of
6850      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6851      number representable as a LONGEST (although either would probably work
6852      in most implementations).  When RU>0, the locution in the then branch
6853      above is always equivalent to the negative of RU.  */
6854
6855   if (new_k != NULL)
6856     *new_k = k;
6857   return 1;
6858 }
6859
6860 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6861    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6862    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
6863
6864 static int
6865 ada_in_variant (LONGEST val, struct type *type, int field_num)
6866 {
6867   const char *name = type->field (field_num).name ();
6868   int p;
6869
6870   p = 0;
6871   while (1)
6872     {
6873       switch (name[p])
6874         {
6875         case '\0':
6876           return 0;
6877         case 'S':
6878           {
6879             LONGEST W;
6880
6881             if (!ada_scan_number (name, p + 1, &W, &p))
6882               return 0;
6883             if (val == W)
6884               return 1;
6885             break;
6886           }
6887         case 'R':
6888           {
6889             LONGEST L, U;
6890
6891             if (!ada_scan_number (name, p + 1, &L, &p)
6892                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6893               return 0;
6894             if (val >= L && val <= U)
6895               return 1;
6896             break;
6897           }
6898         case 'O':
6899           return 1;
6900         default:
6901           return 0;
6902         }
6903     }
6904 }
6905
6906 /* FIXME: Lots of redundancy below.  Try to consolidate.  */
6907
6908 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6909    ARG_TYPE, extract and return the value of one of its (non-static)
6910    fields.  FIELDNO says which field.   Differs from value_primitive_field
6911    only in that it can handle packed values of arbitrary type.  */
6912
6913 struct value *
6914 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6915                            struct type *arg_type)
6916 {
6917   struct type *type;
6918
6919   arg_type = ada_check_typedef (arg_type);
6920   type = arg_type->field (fieldno).type ();
6921
6922   /* Handle packed fields.  It might be that the field is not packed
6923      relative to its containing structure, but the structure itself is
6924      packed; in this case we must take the bit-field path.  */
6925   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6926     {
6927       int bit_pos = arg_type->field (fieldno).loc_bitpos ();
6928       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6929
6930       return ada_value_primitive_packed_val (arg1,
6931                                              value_contents (arg1).data (),
6932                                              offset + bit_pos / 8,
6933                                              bit_pos % 8, bit_size, type);
6934     }
6935   else
6936     return value_primitive_field (arg1, offset, fieldno, arg_type);
6937 }
6938
6939 /* Find field with name NAME in object of type TYPE.  If found, 
6940    set the following for each argument that is non-null:
6941     - *FIELD_TYPE_P to the field's type; 
6942     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 
6943       an object of that type;
6944     - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 
6945     - *BIT_SIZE_P to its size in bits if the field is packed, and 
6946       0 otherwise;
6947    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6948    fields up to but not including the desired field, or by the total
6949    number of fields if not found.   A NULL value of NAME never
6950    matches; the function just counts visible fields in this case.
6951    
6952    Notice that we need to handle when a tagged record hierarchy
6953    has some components with the same name, like in this scenario:
6954
6955       type Top_T is tagged record
6956          N : Integer := 1;
6957          U : Integer := 974;
6958          A : Integer := 48;
6959       end record;
6960
6961       type Middle_T is new Top.Top_T with record
6962          N : Character := 'a';
6963          C : Integer := 3;
6964       end record;
6965
6966      type Bottom_T is new Middle.Middle_T with record
6967         N : Float := 4.0;
6968         C : Character := '5';
6969         X : Integer := 6;
6970         A : Character := 'J';
6971      end record;
6972
6973    Let's say we now have a variable declared and initialized as follow:
6974
6975      TC : Top_A := new Bottom_T;
6976
6977    And then we use this variable to call this function
6978
6979      procedure Assign (Obj: in out Top_T; TV : Integer);
6980
6981    as follow:
6982
6983       Assign (Top_T (B), 12);
6984
6985    Now, we're in the debugger, and we're inside that procedure
6986    then and we want to print the value of obj.c:
6987
6988    Usually, the tagged record or one of the parent type owns the
6989    component to print and there's no issue but in this particular
6990    case, what does it mean to ask for Obj.C? Since the actual
6991    type for object is type Bottom_T, it could mean two things: type
6992    component C from the Middle_T view, but also component C from
6993    Bottom_T.  So in that "undefined" case, when the component is
6994    not found in the non-resolved type (which includes all the
6995    components of the parent type), then resolve it and see if we
6996    get better luck once expanded.
6997
6998    In the case of homonyms in the derived tagged type, we don't
6999    guaranty anything, and pick the one that's easiest for us
7000    to program.
7001
7002    Returns 1 if found, 0 otherwise.  */
7003
7004 static int
7005 find_struct_field (const char *name, struct type *type, int offset,
7006                    struct type **field_type_p,
7007                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7008                    int *index_p)
7009 {
7010   int i;
7011   int parent_offset = -1;
7012
7013   type = ada_check_typedef (type);
7014
7015   if (field_type_p != NULL)
7016     *field_type_p = NULL;
7017   if (byte_offset_p != NULL)
7018     *byte_offset_p = 0;
7019   if (bit_offset_p != NULL)
7020     *bit_offset_p = 0;
7021   if (bit_size_p != NULL)
7022     *bit_size_p = 0;
7023
7024   for (i = 0; i < type->num_fields (); i += 1)
7025     {
7026       /* These can't be computed using TYPE_FIELD_BITPOS for a dynamic
7027          type.  However, we only need the values to be correct when
7028          the caller asks for them.  */
7029       int bit_pos = 0, fld_offset = 0;
7030       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7031         {
7032           bit_pos = type->field (i).loc_bitpos ();
7033           fld_offset = offset + bit_pos / 8;
7034         }
7035
7036       const char *t_field_name = type->field (i).name ();
7037
7038       if (t_field_name == NULL)
7039         continue;
7040
7041       else if (ada_is_parent_field (type, i))
7042         {
7043           /* This is a field pointing us to the parent type of a tagged
7044              type.  As hinted in this function's documentation, we give
7045              preference to fields in the current record first, so what
7046              we do here is just record the index of this field before
7047              we skip it.  If it turns out we couldn't find our field
7048              in the current record, then we'll get back to it and search
7049              inside it whether the field might exist in the parent.  */
7050
7051           parent_offset = i;
7052           continue;
7053         }
7054
7055       else if (name != NULL && field_name_match (t_field_name, name))
7056         {
7057           int bit_size = TYPE_FIELD_BITSIZE (type, i);
7058
7059           if (field_type_p != NULL)
7060             *field_type_p = type->field (i).type ();
7061           if (byte_offset_p != NULL)
7062             *byte_offset_p = fld_offset;
7063           if (bit_offset_p != NULL)
7064             *bit_offset_p = bit_pos % 8;
7065           if (bit_size_p != NULL)
7066             *bit_size_p = bit_size;
7067           return 1;
7068         }
7069       else if (ada_is_wrapper_field (type, i))
7070         {
7071           if (find_struct_field (name, type->field (i).type (), fld_offset,
7072                                  field_type_p, byte_offset_p, bit_offset_p,
7073                                  bit_size_p, index_p))
7074             return 1;
7075         }
7076       else if (ada_is_variant_part (type, i))
7077         {
7078           /* PNH: Wait.  Do we ever execute this section, or is ARG always of 
7079              fixed type?? */
7080           int j;
7081           struct type *field_type
7082             = ada_check_typedef (type->field (i).type ());
7083
7084           for (j = 0; j < field_type->num_fields (); j += 1)
7085             {
7086               if (find_struct_field (name, field_type->field (j).type (),
7087                                      fld_offset
7088                                      + field_type->field (j).loc_bitpos () / 8,
7089                                      field_type_p, byte_offset_p,
7090                                      bit_offset_p, bit_size_p, index_p))
7091                 return 1;
7092             }
7093         }
7094       else if (index_p != NULL)
7095         *index_p += 1;
7096     }
7097
7098   /* Field not found so far.  If this is a tagged type which
7099      has a parent, try finding that field in the parent now.  */
7100
7101   if (parent_offset != -1)
7102     {
7103       /* As above, only compute the offset when truly needed.  */
7104       int fld_offset = offset;
7105       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7106         {
7107           int bit_pos = type->field (parent_offset).loc_bitpos ();
7108           fld_offset += bit_pos / 8;
7109         }
7110
7111       if (find_struct_field (name, type->field (parent_offset).type (),
7112                              fld_offset, field_type_p, byte_offset_p,
7113                              bit_offset_p, bit_size_p, index_p))
7114         return 1;
7115     }
7116
7117   return 0;
7118 }
7119
7120 /* Number of user-visible fields in record type TYPE.  */
7121
7122 static int
7123 num_visible_fields (struct type *type)
7124 {
7125   int n;
7126
7127   n = 0;
7128   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7129   return n;
7130 }
7131
7132 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
7133    and search in it assuming it has (class) type TYPE.
7134    If found, return value, else return NULL.
7135
7136    Searches recursively through wrapper fields (e.g., '_parent').
7137
7138    In the case of homonyms in the tagged types, please refer to the
7139    long explanation in find_struct_field's function documentation.  */
7140
7141 static struct value *
7142 ada_search_struct_field (const char *name, struct value *arg, int offset,
7143                          struct type *type)
7144 {
7145   int i;
7146   int parent_offset = -1;
7147
7148   type = ada_check_typedef (type);
7149   for (i = 0; i < type->num_fields (); i += 1)
7150     {
7151       const char *t_field_name = type->field (i).name ();
7152
7153       if (t_field_name == NULL)
7154         continue;
7155
7156       else if (ada_is_parent_field (type, i))
7157         {
7158           /* This is a field pointing us to the parent type of a tagged
7159              type.  As hinted in this function's documentation, we give
7160              preference to fields in the current record first, so what
7161              we do here is just record the index of this field before
7162              we skip it.  If it turns out we couldn't find our field
7163              in the current record, then we'll get back to it and search
7164              inside it whether the field might exist in the parent.  */
7165
7166           parent_offset = i;
7167           continue;
7168         }
7169
7170       else if (field_name_match (t_field_name, name))
7171         return ada_value_primitive_field (arg, offset, i, type);
7172
7173       else if (ada_is_wrapper_field (type, i))
7174         {
7175           struct value *v =     /* Do not let indent join lines here.  */
7176             ada_search_struct_field (name, arg,
7177                                      offset + type->field (i).loc_bitpos () / 8,
7178                                      type->field (i).type ());
7179
7180           if (v != NULL)
7181             return v;
7182         }
7183
7184       else if (ada_is_variant_part (type, i))
7185         {
7186           /* PNH: Do we ever get here?  See find_struct_field.  */
7187           int j;
7188           struct type *field_type = ada_check_typedef (type->field (i).type ());
7189           int var_offset = offset + type->field (i).loc_bitpos () / 8;
7190
7191           for (j = 0; j < field_type->num_fields (); j += 1)
7192             {
7193               struct value *v = ada_search_struct_field /* Force line
7194                                                            break.  */
7195                 (name, arg,
7196                  var_offset + field_type->field (j).loc_bitpos () / 8,
7197                  field_type->field (j).type ());
7198
7199               if (v != NULL)
7200                 return v;
7201             }
7202         }
7203     }
7204
7205   /* Field not found so far.  If this is a tagged type which
7206      has a parent, try finding that field in the parent now.  */
7207
7208   if (parent_offset != -1)
7209     {
7210       struct value *v = ada_search_struct_field (
7211         name, arg, offset + type->field (parent_offset).loc_bitpos () / 8,
7212         type->field (parent_offset).type ());
7213
7214       if (v != NULL)
7215         return v;
7216     }
7217
7218   return NULL;
7219 }
7220
7221 static struct value *ada_index_struct_field_1 (int *, struct value *,
7222                                                int, struct type *);
7223
7224
7225 /* Return field #INDEX in ARG, where the index is that returned by
7226  * find_struct_field through its INDEX_P argument.  Adjust the address
7227  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7228  * If found, return value, else return NULL.  */
7229
7230 static struct value *
7231 ada_index_struct_field (int index, struct value *arg, int offset,
7232                         struct type *type)
7233 {
7234   return ada_index_struct_field_1 (&index, arg, offset, type);
7235 }
7236
7237
7238 /* Auxiliary function for ada_index_struct_field.  Like
7239  * ada_index_struct_field, but takes index from *INDEX_P and modifies
7240  * *INDEX_P.  */
7241
7242 static struct value *
7243 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7244                           struct type *type)
7245 {
7246   int i;
7247   type = ada_check_typedef (type);
7248
7249   for (i = 0; i < type->num_fields (); i += 1)
7250     {
7251       if (type->field (i).name () == NULL)
7252         continue;
7253       else if (ada_is_wrapper_field (type, i))
7254         {
7255           struct value *v =     /* Do not let indent join lines here.  */
7256             ada_index_struct_field_1 (index_p, arg,
7257                                       offset + type->field (i).loc_bitpos () / 8,
7258                                       type->field (i).type ());
7259
7260           if (v != NULL)
7261             return v;
7262         }
7263
7264       else if (ada_is_variant_part (type, i))
7265         {
7266           /* PNH: Do we ever get here?  See ada_search_struct_field,
7267              find_struct_field.  */
7268           error (_("Cannot assign this kind of variant record"));
7269         }
7270       else if (*index_p == 0)
7271         return ada_value_primitive_field (arg, offset, i, type);
7272       else
7273         *index_p -= 1;
7274     }
7275   return NULL;
7276 }
7277
7278 /* Return a string representation of type TYPE.  */
7279
7280 static std::string
7281 type_as_string (struct type *type)
7282 {
7283   string_file tmp_stream;
7284
7285   type_print (type, "", &tmp_stream, -1);
7286
7287   return tmp_stream.release ();
7288 }
7289
7290 /* Given a type TYPE, look up the type of the component of type named NAME.
7291    If DISPP is non-null, add its byte displacement from the beginning of a
7292    structure (pointed to by a value) of type TYPE to *DISPP (does not
7293    work for packed fields).
7294
7295    Matches any field whose name has NAME as a prefix, possibly
7296    followed by "___".
7297
7298    TYPE can be either a struct or union.  If REFOK, TYPE may also 
7299    be a (pointer or reference)+ to a struct or union, and the
7300    ultimate target type will be searched.
7301
7302    Looks recursively into variant clauses and parent types.
7303
7304    In the case of homonyms in the tagged types, please refer to the
7305    long explanation in find_struct_field's function documentation.
7306
7307    If NOERR is nonzero, return NULL if NAME is not suitably defined or
7308    TYPE is not a type of the right kind.  */
7309
7310 static struct type *
7311 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7312                             int noerr)
7313 {
7314   int i;
7315   int parent_offset = -1;
7316
7317   if (name == NULL)
7318     goto BadName;
7319
7320   if (refok && type != NULL)
7321     while (1)
7322       {
7323         type = ada_check_typedef (type);
7324         if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
7325           break;
7326         type = type->target_type ();
7327       }
7328
7329   if (type == NULL
7330       || (type->code () != TYPE_CODE_STRUCT
7331           && type->code () != TYPE_CODE_UNION))
7332     {
7333       if (noerr)
7334         return NULL;
7335
7336       error (_("Type %s is not a structure or union type"),
7337              type != NULL ? type_as_string (type).c_str () : _("(null)"));
7338     }
7339
7340   type = to_static_fixed_type (type);
7341
7342   for (i = 0; i < type->num_fields (); i += 1)
7343     {
7344       const char *t_field_name = type->field (i).name ();
7345       struct type *t;
7346
7347       if (t_field_name == NULL)
7348         continue;
7349
7350       else if (ada_is_parent_field (type, i))
7351         {
7352           /* This is a field pointing us to the parent type of a tagged
7353              type.  As hinted in this function's documentation, we give
7354              preference to fields in the current record first, so what
7355              we do here is just record the index of this field before
7356              we skip it.  If it turns out we couldn't find our field
7357              in the current record, then we'll get back to it and search
7358              inside it whether the field might exist in the parent.  */
7359
7360           parent_offset = i;
7361           continue;
7362         }
7363
7364       else if (field_name_match (t_field_name, name))
7365         return type->field (i).type ();
7366
7367       else if (ada_is_wrapper_field (type, i))
7368         {
7369           t = ada_lookup_struct_elt_type (type->field (i).type (), name,
7370                                           0, 1);
7371           if (t != NULL)
7372             return t;
7373         }
7374
7375       else if (ada_is_variant_part (type, i))
7376         {
7377           int j;
7378           struct type *field_type = ada_check_typedef (type->field (i).type ());
7379
7380           for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
7381             {
7382               /* FIXME pnh 2008/01/26: We check for a field that is
7383                  NOT wrapped in a struct, since the compiler sometimes
7384                  generates these for unchecked variant types.  Revisit
7385                  if the compiler changes this practice.  */
7386               const char *v_field_name = field_type->field (j).name ();
7387
7388               if (v_field_name != NULL 
7389                   && field_name_match (v_field_name, name))
7390                 t = field_type->field (j).type ();
7391               else
7392                 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
7393                                                 name, 0, 1);
7394
7395               if (t != NULL)
7396                 return t;
7397             }
7398         }
7399
7400     }
7401
7402     /* Field not found so far.  If this is a tagged type which
7403        has a parent, try finding that field in the parent now.  */
7404
7405     if (parent_offset != -1)
7406       {
7407         struct type *t;
7408
7409         t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
7410                                         name, 0, 1);
7411         if (t != NULL)
7412           return t;
7413       }
7414
7415 BadName:
7416   if (!noerr)
7417     {
7418       const char *name_str = name != NULL ? name : _("<null>");
7419
7420       error (_("Type %s has no component named %s"),
7421              type_as_string (type).c_str (), name_str);
7422     }
7423
7424   return NULL;
7425 }
7426
7427 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7428    within a value of type OUTER_TYPE, return true iff VAR_TYPE
7429    represents an unchecked union (that is, the variant part of a
7430    record that is named in an Unchecked_Union pragma).  */
7431
7432 static int
7433 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7434 {
7435   const char *discrim_name = ada_variant_discrim_name (var_type);
7436
7437   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7438 }
7439
7440
7441 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7442    within OUTER, determine which variant clause (field number in VAR_TYPE,
7443    numbering from 0) is applicable.  Returns -1 if none are.  */
7444
7445 int
7446 ada_which_variant_applies (struct type *var_type, struct value *outer)
7447 {
7448   int others_clause;
7449   int i;
7450   const char *discrim_name = ada_variant_discrim_name (var_type);
7451   struct value *discrim;
7452   LONGEST discrim_val;
7453
7454   /* Using plain value_from_contents_and_address here causes problems
7455      because we will end up trying to resolve a type that is currently
7456      being constructed.  */
7457   discrim = ada_value_struct_elt (outer, discrim_name, 1);
7458   if (discrim == NULL)
7459     return -1;
7460   discrim_val = value_as_long (discrim);
7461
7462   others_clause = -1;
7463   for (i = 0; i < var_type->num_fields (); i += 1)
7464     {
7465       if (ada_is_others_clause (var_type, i))
7466         others_clause = i;
7467       else if (ada_in_variant (discrim_val, var_type, i))
7468         return i;
7469     }
7470
7471   return others_clause;
7472 }
7473 \f
7474
7475
7476                                 /* Dynamic-Sized Records */
7477
7478 /* Strategy: The type ostensibly attached to a value with dynamic size
7479    (i.e., a size that is not statically recorded in the debugging
7480    data) does not accurately reflect the size or layout of the value.
7481    Our strategy is to convert these values to values with accurate,
7482    conventional types that are constructed on the fly.  */
7483
7484 /* There is a subtle and tricky problem here.  In general, we cannot
7485    determine the size of dynamic records without its data.  However,
7486    the 'struct value' data structure, which GDB uses to represent
7487    quantities in the inferior process (the target), requires the size
7488    of the type at the time of its allocation in order to reserve space
7489    for GDB's internal copy of the data.  That's why the
7490    'to_fixed_xxx_type' routines take (target) addresses as parameters,
7491    rather than struct value*s.
7492
7493    However, GDB's internal history variables ($1, $2, etc.) are
7494    struct value*s containing internal copies of the data that are not, in
7495    general, the same as the data at their corresponding addresses in
7496    the target.  Fortunately, the types we give to these values are all
7497    conventional, fixed-size types (as per the strategy described
7498    above), so that we don't usually have to perform the
7499    'to_fixed_xxx_type' conversions to look at their values.
7500    Unfortunately, there is one exception: if one of the internal
7501    history variables is an array whose elements are unconstrained
7502    records, then we will need to create distinct fixed types for each
7503    element selected.  */
7504
7505 /* The upshot of all of this is that many routines take a (type, host
7506    address, target address) triple as arguments to represent a value.
7507    The host address, if non-null, is supposed to contain an internal
7508    copy of the relevant data; otherwise, the program is to consult the
7509    target at the target address.  */
7510
7511 /* Assuming that VAL0 represents a pointer value, the result of
7512    dereferencing it.  Differs from value_ind in its treatment of
7513    dynamic-sized types.  */
7514
7515 struct value *
7516 ada_value_ind (struct value *val0)
7517 {
7518   struct value *val = value_ind (val0);
7519
7520   if (ada_is_tagged_type (value_type (val), 0))
7521     val = ada_tag_value_at_base_address (val);
7522
7523   return ada_to_fixed_value (val);
7524 }
7525
7526 /* The value resulting from dereferencing any "reference to"
7527    qualifiers on VAL0.  */
7528
7529 static struct value *
7530 ada_coerce_ref (struct value *val0)
7531 {
7532   if (value_type (val0)->code () == TYPE_CODE_REF)
7533     {
7534       struct value *val = val0;
7535
7536       val = coerce_ref (val);
7537
7538       if (ada_is_tagged_type (value_type (val), 0))
7539         val = ada_tag_value_at_base_address (val);
7540
7541       return ada_to_fixed_value (val);
7542     }
7543   else
7544     return val0;
7545 }
7546
7547 /* Return the bit alignment required for field #F of template type TYPE.  */
7548
7549 static unsigned int
7550 field_alignment (struct type *type, int f)
7551 {
7552   const char *name = type->field (f).name ();
7553   int len;
7554   int align_offset;
7555
7556   /* The field name should never be null, unless the debugging information
7557      is somehow malformed.  In this case, we assume the field does not
7558      require any alignment.  */
7559   if (name == NULL)
7560     return 1;
7561
7562   len = strlen (name);
7563
7564   if (!isdigit (name[len - 1]))
7565     return 1;
7566
7567   if (isdigit (name[len - 2]))
7568     align_offset = len - 2;
7569   else
7570     align_offset = len - 1;
7571
7572   if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7573     return TARGET_CHAR_BIT;
7574
7575   return atoi (name + align_offset) * TARGET_CHAR_BIT;
7576 }
7577
7578 /* Find a typedef or tag symbol named NAME.  Ignores ambiguity.  */
7579
7580 static struct symbol *
7581 ada_find_any_type_symbol (const char *name)
7582 {
7583   struct symbol *sym;
7584
7585   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7586   if (sym != NULL && sym->aclass () == LOC_TYPEDEF)
7587     return sym;
7588
7589   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7590   return sym;
7591 }
7592
7593 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
7594    solely for types defined by debug info, it will not search the GDB
7595    primitive types.  */
7596
7597 static struct type *
7598 ada_find_any_type (const char *name)
7599 {
7600   struct symbol *sym = ada_find_any_type_symbol (name);
7601
7602   if (sym != NULL)
7603     return sym->type ();
7604
7605   return NULL;
7606 }
7607
7608 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7609    associated with NAME_SYM's name.  NAME_SYM may itself be a renaming
7610    symbol, in which case it is returned.  Otherwise, this looks for
7611    symbols whose name is that of NAME_SYM suffixed with  "___XR".
7612    Return symbol if found, and NULL otherwise.  */
7613
7614 static bool
7615 ada_is_renaming_symbol (struct symbol *name_sym)
7616 {
7617   const char *name = name_sym->linkage_name ();
7618   return strstr (name, "___XR") != NULL;
7619 }
7620
7621 /* Because of GNAT encoding conventions, several GDB symbols may match a
7622    given type name.  If the type denoted by TYPE0 is to be preferred to
7623    that of TYPE1 for purposes of type printing, return non-zero;
7624    otherwise return 0.  */
7625
7626 int
7627 ada_prefer_type (struct type *type0, struct type *type1)
7628 {
7629   if (type1 == NULL)
7630     return 1;
7631   else if (type0 == NULL)
7632     return 0;
7633   else if (type1->code () == TYPE_CODE_VOID)
7634     return 1;
7635   else if (type0->code () == TYPE_CODE_VOID)
7636     return 0;
7637   else if (type1->name () == NULL && type0->name () != NULL)
7638     return 1;
7639   else if (ada_is_constrained_packed_array_type (type0))
7640     return 1;
7641   else if (ada_is_array_descriptor_type (type0)
7642            && !ada_is_array_descriptor_type (type1))
7643     return 1;
7644   else
7645     {
7646       const char *type0_name = type0->name ();
7647       const char *type1_name = type1->name ();
7648
7649       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7650           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7651         return 1;
7652     }
7653   return 0;
7654 }
7655
7656 /* The name of TYPE, which is its TYPE_NAME.  Null if TYPE is
7657    null.  */
7658
7659 const char *
7660 ada_type_name (struct type *type)
7661 {
7662   if (type == NULL)
7663     return NULL;
7664   return type->name ();
7665 }
7666
7667 /* Search the list of "descriptive" types associated to TYPE for a type
7668    whose name is NAME.  */
7669
7670 static struct type *
7671 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7672 {
7673   struct type *result, *tmp;
7674
7675   if (ada_ignore_descriptive_types_p)
7676     return NULL;
7677
7678   /* If there no descriptive-type info, then there is no parallel type
7679      to be found.  */
7680   if (!HAVE_GNAT_AUX_INFO (type))
7681     return NULL;
7682
7683   result = TYPE_DESCRIPTIVE_TYPE (type);
7684   while (result != NULL)
7685     {
7686       const char *result_name = ada_type_name (result);
7687
7688       if (result_name == NULL)
7689         {
7690           warning (_("unexpected null name on descriptive type"));
7691           return NULL;
7692         }
7693
7694       /* If the names match, stop.  */
7695       if (strcmp (result_name, name) == 0)
7696         break;
7697
7698       /* Otherwise, look at the next item on the list, if any.  */
7699       if (HAVE_GNAT_AUX_INFO (result))
7700         tmp = TYPE_DESCRIPTIVE_TYPE (result);
7701       else
7702         tmp = NULL;
7703
7704       /* If not found either, try after having resolved the typedef.  */
7705       if (tmp != NULL)
7706         result = tmp;
7707       else
7708         {
7709           result = check_typedef (result);
7710           if (HAVE_GNAT_AUX_INFO (result))
7711             result = TYPE_DESCRIPTIVE_TYPE (result);
7712           else
7713             result = NULL;
7714         }
7715     }
7716
7717   /* If we didn't find a match, see whether this is a packed array.  With
7718      older compilers, the descriptive type information is either absent or
7719      irrelevant when it comes to packed arrays so the above lookup fails.
7720      Fall back to using a parallel lookup by name in this case.  */
7721   if (result == NULL && ada_is_constrained_packed_array_type (type))
7722     return ada_find_any_type (name);
7723
7724   return result;
7725 }
7726
7727 /* Find a parallel type to TYPE with the specified NAME, using the
7728    descriptive type taken from the debugging information, if available,
7729    and otherwise using the (slower) name-based method.  */
7730
7731 static struct type *
7732 ada_find_parallel_type_with_name (struct type *type, const char *name)
7733 {
7734   struct type *result = NULL;
7735
7736   if (HAVE_GNAT_AUX_INFO (type))
7737     result = find_parallel_type_by_descriptive_type (type, name);
7738   else
7739     result = ada_find_any_type (name);
7740
7741   return result;
7742 }
7743
7744 /* Same as above, but specify the name of the parallel type by appending
7745    SUFFIX to the name of TYPE.  */
7746
7747 struct type *
7748 ada_find_parallel_type (struct type *type, const char *suffix)
7749 {
7750   char *name;
7751   const char *type_name = ada_type_name (type);
7752   int len;
7753
7754   if (type_name == NULL)
7755     return NULL;
7756
7757   len = strlen (type_name);
7758
7759   name = (char *) alloca (len + strlen (suffix) + 1);
7760
7761   strcpy (name, type_name);
7762   strcpy (name + len, suffix);
7763
7764   return ada_find_parallel_type_with_name (type, name);
7765 }
7766
7767 /* If TYPE is a variable-size record type, return the corresponding template
7768    type describing its fields.  Otherwise, return NULL.  */
7769
7770 static struct type *
7771 dynamic_template_type (struct type *type)
7772 {
7773   type = ada_check_typedef (type);
7774
7775   if (type == NULL || type->code () != TYPE_CODE_STRUCT
7776       || ada_type_name (type) == NULL)
7777     return NULL;
7778   else
7779     {
7780       int len = strlen (ada_type_name (type));
7781
7782       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7783         return type;
7784       else
7785         return ada_find_parallel_type (type, "___XVE");
7786     }
7787 }
7788
7789 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7790    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
7791
7792 static int
7793 is_dynamic_field (struct type *templ_type, int field_num)
7794 {
7795   const char *name = templ_type->field (field_num).name ();
7796
7797   return name != NULL
7798     && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7799     && strstr (name, "___XVL") != NULL;
7800 }
7801
7802 /* The index of the variant field of TYPE, or -1 if TYPE does not
7803    represent a variant record type.  */
7804
7805 static int
7806 variant_field_index (struct type *type)
7807 {
7808   int f;
7809
7810   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7811     return -1;
7812
7813   for (f = 0; f < type->num_fields (); f += 1)
7814     {
7815       if (ada_is_variant_part (type, f))
7816         return f;
7817     }
7818   return -1;
7819 }
7820
7821 /* A record type with no fields.  */
7822
7823 static struct type *
7824 empty_record (struct type *templ)
7825 {
7826   struct type *type = alloc_type_copy (templ);
7827
7828   type->set_code (TYPE_CODE_STRUCT);
7829   INIT_NONE_SPECIFIC (type);
7830   type->set_name ("<empty>");
7831   type->set_length (0);
7832   return type;
7833 }
7834
7835 /* An ordinary record type (with fixed-length fields) that describes
7836    the value of type TYPE at VALADDR or ADDRESS (see comments at
7837    the beginning of this section) VAL according to GNAT conventions.
7838    DVAL0 should describe the (portion of a) record that contains any
7839    necessary discriminants.  It should be NULL if value_type (VAL) is
7840    an outer-level type (i.e., as opposed to a branch of a variant.)  A
7841    variant field (unless unchecked) is replaced by a particular branch
7842    of the variant.
7843
7844    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7845    length are not statically known are discarded.  As a consequence,
7846    VALADDR, ADDRESS and DVAL0 are ignored.
7847
7848    NOTE: Limitations: For now, we assume that dynamic fields and
7849    variants occupy whole numbers of bytes.  However, they need not be
7850    byte-aligned.  */
7851
7852 struct type *
7853 ada_template_to_fixed_record_type_1 (struct type *type,
7854                                      const gdb_byte *valaddr,
7855                                      CORE_ADDR address, struct value *dval0,
7856                                      int keep_dynamic_fields)
7857 {
7858   struct value *mark = value_mark ();
7859   struct value *dval;
7860   struct type *rtype;
7861   int nfields, bit_len;
7862   int variant_field;
7863   long off;
7864   int fld_bit_len;
7865   int f;
7866
7867   /* Compute the number of fields in this record type that are going
7868      to be processed: unless keep_dynamic_fields, this includes only
7869      fields whose position and length are static will be processed.  */
7870   if (keep_dynamic_fields)
7871     nfields = type->num_fields ();
7872   else
7873     {
7874       nfields = 0;
7875       while (nfields < type->num_fields ()
7876              && !ada_is_variant_part (type, nfields)
7877              && !is_dynamic_field (type, nfields))
7878         nfields++;
7879     }
7880
7881   rtype = alloc_type_copy (type);
7882   rtype->set_code (TYPE_CODE_STRUCT);
7883   INIT_NONE_SPECIFIC (rtype);
7884   rtype->set_num_fields (nfields);
7885   rtype->set_fields
7886    ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7887   rtype->set_name (ada_type_name (type));
7888   rtype->set_is_fixed_instance (true);
7889
7890   off = 0;
7891   bit_len = 0;
7892   variant_field = -1;
7893
7894   for (f = 0; f < nfields; f += 1)
7895     {
7896       off = align_up (off, field_alignment (type, f))
7897         + type->field (f).loc_bitpos ();
7898       rtype->field (f).set_loc_bitpos (off);
7899       TYPE_FIELD_BITSIZE (rtype, f) = 0;
7900
7901       if (ada_is_variant_part (type, f))
7902         {
7903           variant_field = f;
7904           fld_bit_len = 0;
7905         }
7906       else if (is_dynamic_field (type, f))
7907         {
7908           const gdb_byte *field_valaddr = valaddr;
7909           CORE_ADDR field_address = address;
7910           struct type *field_type = type->field (f).type ()->target_type ();
7911
7912           if (dval0 == NULL)
7913             {
7914               /* Using plain value_from_contents_and_address here
7915                  causes problems because we will end up trying to
7916                  resolve a type that is currently being
7917                  constructed.  */
7918               dval = value_from_contents_and_address_unresolved (rtype,
7919                                                                  valaddr,
7920                                                                  address);
7921               rtype = value_type (dval);
7922             }
7923           else
7924             dval = dval0;
7925
7926           /* If the type referenced by this field is an aligner type, we need
7927              to unwrap that aligner type, because its size might not be set.
7928              Keeping the aligner type would cause us to compute the wrong
7929              size for this field, impacting the offset of the all the fields
7930              that follow this one.  */
7931           if (ada_is_aligner_type (field_type))
7932             {
7933               long field_offset = type->field (f).loc_bitpos ();
7934
7935               field_valaddr = cond_offset_host (field_valaddr, field_offset);
7936               field_address = cond_offset_target (field_address, field_offset);
7937               field_type = ada_aligned_type (field_type);
7938             }
7939
7940           field_valaddr = cond_offset_host (field_valaddr,
7941                                             off / TARGET_CHAR_BIT);
7942           field_address = cond_offset_target (field_address,
7943                                               off / TARGET_CHAR_BIT);
7944
7945           /* Get the fixed type of the field.  Note that, in this case,
7946              we do not want to get the real type out of the tag: if
7947              the current field is the parent part of a tagged record,
7948              we will get the tag of the object.  Clearly wrong: the real
7949              type of the parent is not the real type of the child.  We
7950              would end up in an infinite loop.  */
7951           field_type = ada_get_base_type (field_type);
7952           field_type = ada_to_fixed_type (field_type, field_valaddr,
7953                                           field_address, dval, 0);
7954
7955           rtype->field (f).set_type (field_type);
7956           rtype->field (f).set_name (type->field (f).name ());
7957           /* The multiplication can potentially overflow.  But because
7958              the field length has been size-checked just above, and
7959              assuming that the maximum size is a reasonable value,
7960              an overflow should not happen in practice.  So rather than
7961              adding overflow recovery code to this already complex code,
7962              we just assume that it's not going to happen.  */
7963           fld_bit_len = rtype->field (f).type ()->length () * TARGET_CHAR_BIT;
7964         }
7965       else
7966         {
7967           /* Note: If this field's type is a typedef, it is important
7968              to preserve the typedef layer.
7969
7970              Otherwise, we might be transforming a typedef to a fat
7971              pointer (encoding a pointer to an unconstrained array),
7972              into a basic fat pointer (encoding an unconstrained
7973              array).  As both types are implemented using the same
7974              structure, the typedef is the only clue which allows us
7975              to distinguish between the two options.  Stripping it
7976              would prevent us from printing this field appropriately.  */
7977           rtype->field (f).set_type (type->field (f).type ());
7978           rtype->field (f).set_name (type->field (f).name ());
7979           if (TYPE_FIELD_BITSIZE (type, f) > 0)
7980             fld_bit_len =
7981               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7982           else
7983             {
7984               struct type *field_type = type->field (f).type ();
7985
7986               /* We need to be careful of typedefs when computing
7987                  the length of our field.  If this is a typedef,
7988                  get the length of the target type, not the length
7989                  of the typedef.  */
7990               if (field_type->code () == TYPE_CODE_TYPEDEF)
7991                 field_type = ada_typedef_target_type (field_type);
7992
7993               fld_bit_len =
7994                 ada_check_typedef (field_type)->length () * TARGET_CHAR_BIT;
7995             }
7996         }
7997       if (off + fld_bit_len > bit_len)
7998         bit_len = off + fld_bit_len;
7999       off += fld_bit_len;
8000       rtype->set_length (align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT);
8001     }
8002
8003   /* We handle the variant part, if any, at the end because of certain
8004      odd cases in which it is re-ordered so as NOT to be the last field of
8005      the record.  This can happen in the presence of representation
8006      clauses.  */
8007   if (variant_field >= 0)
8008     {
8009       struct type *branch_type;
8010
8011       off = rtype->field (variant_field).loc_bitpos ();
8012
8013       if (dval0 == NULL)
8014         {
8015           /* Using plain value_from_contents_and_address here causes
8016              problems because we will end up trying to resolve a type
8017              that is currently being constructed.  */
8018           dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8019                                                              address);
8020           rtype = value_type (dval);
8021         }
8022       else
8023         dval = dval0;
8024
8025       branch_type =
8026         to_fixed_variant_branch_type
8027         (type->field (variant_field).type (),
8028          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8029          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8030       if (branch_type == NULL)
8031         {
8032           for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
8033             rtype->field (f - 1) = rtype->field (f);
8034           rtype->set_num_fields (rtype->num_fields () - 1);
8035         }
8036       else
8037         {
8038           rtype->field (variant_field).set_type (branch_type);
8039           rtype->field (variant_field).set_name ("S");
8040           fld_bit_len =
8041             rtype->field (variant_field).type ()->length () * TARGET_CHAR_BIT;
8042           if (off + fld_bit_len > bit_len)
8043             bit_len = off + fld_bit_len;
8044
8045           rtype->set_length
8046             (align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT);
8047         }
8048     }
8049
8050   /* According to exp_dbug.ads, the size of TYPE for variable-size records
8051      should contain the alignment of that record, which should be a strictly
8052      positive value.  If null or negative, then something is wrong, most
8053      probably in the debug info.  In that case, we don't round up the size
8054      of the resulting type.  If this record is not part of another structure,
8055      the current RTYPE length might be good enough for our purposes.  */
8056   if (type->length () <= 0)
8057     {
8058       if (rtype->name ())
8059         warning (_("Invalid type size for `%s' detected: %s."),
8060                  rtype->name (), pulongest (type->length ()));
8061       else
8062         warning (_("Invalid type size for <unnamed> detected: %s."),
8063                  pulongest (type->length ()));
8064     }
8065   else
8066     rtype->set_length (align_up (rtype->length (), type->length ()));
8067
8068   value_free_to_mark (mark);
8069   return rtype;
8070 }
8071
8072 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8073    of 1.  */
8074
8075 static struct type *
8076 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8077                                CORE_ADDR address, struct value *dval0)
8078 {
8079   return ada_template_to_fixed_record_type_1 (type, valaddr,
8080                                               address, dval0, 1);
8081 }
8082
8083 /* An ordinary record type in which ___XVL-convention fields and
8084    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8085    static approximations, containing all possible fields.  Uses
8086    no runtime values.  Useless for use in values, but that's OK,
8087    since the results are used only for type determinations.   Works on both
8088    structs and unions.  Representation note: to save space, we memorize
8089    the result of this function in the type::target_type of the
8090    template type.  */
8091
8092 static struct type *
8093 template_to_static_fixed_type (struct type *type0)
8094 {
8095   struct type *type;
8096   int nfields;
8097   int f;
8098
8099   /* No need no do anything if the input type is already fixed.  */
8100   if (type0->is_fixed_instance ())
8101     return type0;
8102
8103   /* Likewise if we already have computed the static approximation.  */
8104   if (type0->target_type () != NULL)
8105     return type0->target_type ();
8106
8107   /* Don't clone TYPE0 until we are sure we are going to need a copy.  */
8108   type = type0;
8109   nfields = type0->num_fields ();
8110
8111   /* Whether or not we cloned TYPE0, cache the result so that we don't do
8112      recompute all over next time.  */
8113   type0->set_target_type (type);
8114
8115   for (f = 0; f < nfields; f += 1)
8116     {
8117       struct type *field_type = type0->field (f).type ();
8118       struct type *new_type;
8119
8120       if (is_dynamic_field (type0, f))
8121         {
8122           field_type = ada_check_typedef (field_type);
8123           new_type = to_static_fixed_type (field_type->target_type ());
8124         }
8125       else
8126         new_type = static_unwrap_type (field_type);
8127
8128       if (new_type != field_type)
8129         {
8130           /* Clone TYPE0 only the first time we get a new field type.  */
8131           if (type == type0)
8132             {
8133               type = alloc_type_copy (type0);
8134               type0->set_target_type (type);
8135               type->set_code (type0->code ());
8136               INIT_NONE_SPECIFIC (type);
8137               type->set_num_fields (nfields);
8138
8139               field *fields =
8140                 ((struct field *)
8141                  TYPE_ALLOC (type, nfields * sizeof (struct field)));
8142               memcpy (fields, type0->fields (),
8143                       sizeof (struct field) * nfields);
8144               type->set_fields (fields);
8145
8146               type->set_name (ada_type_name (type0));
8147               type->set_is_fixed_instance (true);
8148               type->set_length (0);
8149             }
8150           type->field (f).set_type (new_type);
8151           type->field (f).set_name (type0->field (f).name ());
8152         }
8153     }
8154
8155   return type;
8156 }
8157
8158 /* Given an object of type TYPE whose contents are at VALADDR and
8159    whose address in memory is ADDRESS, returns a revision of TYPE,
8160    which should be a non-dynamic-sized record, in which the variant
8161    part, if any, is replaced with the appropriate branch.  Looks
8162    for discriminant values in DVAL0, which can be NULL if the record
8163    contains the necessary discriminant values.  */
8164
8165 static struct type *
8166 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8167                                    CORE_ADDR address, struct value *dval0)
8168 {
8169   struct value *mark = value_mark ();
8170   struct value *dval;
8171   struct type *rtype;
8172   struct type *branch_type;
8173   int nfields = type->num_fields ();
8174   int variant_field = variant_field_index (type);
8175
8176   if (variant_field == -1)
8177     return type;
8178
8179   if (dval0 == NULL)
8180     {
8181       dval = value_from_contents_and_address (type, valaddr, address);
8182       type = value_type (dval);
8183     }
8184   else
8185     dval = dval0;
8186
8187   rtype = alloc_type_copy (type);
8188   rtype->set_code (TYPE_CODE_STRUCT);
8189   INIT_NONE_SPECIFIC (rtype);
8190   rtype->set_num_fields (nfields);
8191
8192   field *fields =
8193     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8194   memcpy (fields, type->fields (), sizeof (struct field) * nfields);
8195   rtype->set_fields (fields);
8196
8197   rtype->set_name (ada_type_name (type));
8198   rtype->set_is_fixed_instance (true);
8199   rtype->set_length (type->length ());
8200
8201   branch_type = to_fixed_variant_branch_type
8202     (type->field (variant_field).type (),
8203      cond_offset_host (valaddr,
8204                        type->field (variant_field).loc_bitpos ()
8205                        / TARGET_CHAR_BIT),
8206      cond_offset_target (address,
8207                          type->field (variant_field).loc_bitpos ()
8208                          / TARGET_CHAR_BIT), dval);
8209   if (branch_type == NULL)
8210     {
8211       int f;
8212
8213       for (f = variant_field + 1; f < nfields; f += 1)
8214         rtype->field (f - 1) = rtype->field (f);
8215       rtype->set_num_fields (rtype->num_fields () - 1);
8216     }
8217   else
8218     {
8219       rtype->field (variant_field).set_type (branch_type);
8220       rtype->field (variant_field).set_name ("S");
8221       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8222       rtype->set_length (rtype->length () + branch_type->length ());
8223     }
8224
8225   rtype->set_length (rtype->length ()
8226                      - type->field (variant_field).type ()->length ());
8227
8228   value_free_to_mark (mark);
8229   return rtype;
8230 }
8231
8232 /* An ordinary record type (with fixed-length fields) that describes
8233    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8234    beginning of this section].   Any necessary discriminants' values
8235    should be in DVAL, a record value; it may be NULL if the object
8236    at ADDR itself contains any necessary discriminant values.
8237    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8238    values from the record are needed.  Except in the case that DVAL,
8239    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8240    unchecked) is replaced by a particular branch of the variant.
8241
8242    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8243    is questionable and may be removed.  It can arise during the
8244    processing of an unconstrained-array-of-record type where all the
8245    variant branches have exactly the same size.  This is because in
8246    such cases, the compiler does not bother to use the XVS convention
8247    when encoding the record.  I am currently dubious of this
8248    shortcut and suspect the compiler should be altered.  FIXME.  */
8249
8250 static struct type *
8251 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8252                       CORE_ADDR address, struct value *dval)
8253 {
8254   struct type *templ_type;
8255
8256   if (type0->is_fixed_instance ())
8257     return type0;
8258
8259   templ_type = dynamic_template_type (type0);
8260
8261   if (templ_type != NULL)
8262     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8263   else if (variant_field_index (type0) >= 0)
8264     {
8265       if (dval == NULL && valaddr == NULL && address == 0)
8266         return type0;
8267       return to_record_with_fixed_variant_part (type0, valaddr, address,
8268                                                 dval);
8269     }
8270   else
8271     {
8272       type0->set_is_fixed_instance (true);
8273       return type0;
8274     }
8275
8276 }
8277
8278 /* An ordinary record type (with fixed-length fields) that describes
8279    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8280    union type.  Any necessary discriminants' values should be in DVAL,
8281    a record value.  That is, this routine selects the appropriate
8282    branch of the union at ADDR according to the discriminant value
8283    indicated in the union's type name.  Returns VAR_TYPE0 itself if
8284    it represents a variant subject to a pragma Unchecked_Union.  */
8285
8286 static struct type *
8287 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8288                               CORE_ADDR address, struct value *dval)
8289 {
8290   int which;
8291   struct type *templ_type;
8292   struct type *var_type;
8293
8294   if (var_type0->code () == TYPE_CODE_PTR)
8295     var_type = var_type0->target_type ();
8296   else
8297     var_type = var_type0;
8298
8299   templ_type = ada_find_parallel_type (var_type, "___XVU");
8300
8301   if (templ_type != NULL)
8302     var_type = templ_type;
8303
8304   if (is_unchecked_variant (var_type, value_type (dval)))
8305       return var_type0;
8306   which = ada_which_variant_applies (var_type, dval);
8307
8308   if (which < 0)
8309     return empty_record (var_type);
8310   else if (is_dynamic_field (var_type, which))
8311     return to_fixed_record_type
8312       (var_type->field (which).type ()->target_type(), valaddr, address, dval);
8313   else if (variant_field_index (var_type->field (which).type ()) >= 0)
8314     return
8315       to_fixed_record_type
8316       (var_type->field (which).type (), valaddr, address, dval);
8317   else
8318     return var_type->field (which).type ();
8319 }
8320
8321 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8322    ENCODING_TYPE, a type following the GNAT conventions for discrete
8323    type encodings, only carries redundant information.  */
8324
8325 static int
8326 ada_is_redundant_range_encoding (struct type *range_type,
8327                                  struct type *encoding_type)
8328 {
8329   const char *bounds_str;
8330   int n;
8331   LONGEST lo, hi;
8332
8333   gdb_assert (range_type->code () == TYPE_CODE_RANGE);
8334
8335   if (get_base_type (range_type)->code ()
8336       != get_base_type (encoding_type)->code ())
8337     {
8338       /* The compiler probably used a simple base type to describe
8339          the range type instead of the range's actual base type,
8340          expecting us to get the real base type from the encoding
8341          anyway.  In this situation, the encoding cannot be ignored
8342          as redundant.  */
8343       return 0;
8344     }
8345
8346   if (is_dynamic_type (range_type))
8347     return 0;
8348
8349   if (encoding_type->name () == NULL)
8350     return 0;
8351
8352   bounds_str = strstr (encoding_type->name (), "___XDLU_");
8353   if (bounds_str == NULL)
8354     return 0;
8355
8356   n = 8; /* Skip "___XDLU_".  */
8357   if (!ada_scan_number (bounds_str, n, &lo, &n))
8358     return 0;
8359   if (range_type->bounds ()->low.const_val () != lo)
8360     return 0;
8361
8362   n += 2; /* Skip the "__" separator between the two bounds.  */
8363   if (!ada_scan_number (bounds_str, n, &hi, &n))
8364     return 0;
8365   if (range_type->bounds ()->high.const_val () != hi)
8366     return 0;
8367
8368   return 1;
8369 }
8370
8371 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8372    a type following the GNAT encoding for describing array type
8373    indices, only carries redundant information.  */
8374
8375 static int
8376 ada_is_redundant_index_type_desc (struct type *array_type,
8377                                   struct type *desc_type)
8378 {
8379   struct type *this_layer = check_typedef (array_type);
8380   int i;
8381
8382   for (i = 0; i < desc_type->num_fields (); i++)
8383     {
8384       if (!ada_is_redundant_range_encoding (this_layer->index_type (),
8385                                             desc_type->field (i).type ()))
8386         return 0;
8387       this_layer = check_typedef (this_layer->target_type ());
8388     }
8389
8390   return 1;
8391 }
8392
8393 /* Assuming that TYPE0 is an array type describing the type of a value
8394    at ADDR, and that DVAL describes a record containing any
8395    discriminants used in TYPE0, returns a type for the value that
8396    contains no dynamic components (that is, no components whose sizes
8397    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
8398    true, gives an error message if the resulting type's size is over
8399    varsize_limit.  */
8400
8401 static struct type *
8402 to_fixed_array_type (struct type *type0, struct value *dval,
8403                      int ignore_too_big)
8404 {
8405   struct type *index_type_desc;
8406   struct type *result;
8407   int constrained_packed_array_p;
8408   static const char *xa_suffix = "___XA";
8409
8410   type0 = ada_check_typedef (type0);
8411   if (type0->is_fixed_instance ())
8412     return type0;
8413
8414   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8415   if (constrained_packed_array_p)
8416     {
8417       type0 = decode_constrained_packed_array_type (type0);
8418       if (type0 == nullptr)
8419         error (_("could not decode constrained packed array type"));
8420     }
8421
8422   index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8423
8424   /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8425      encoding suffixed with 'P' may still be generated.  If so,
8426      it should be used to find the XA type.  */
8427
8428   if (index_type_desc == NULL)
8429     {
8430       const char *type_name = ada_type_name (type0);
8431
8432       if (type_name != NULL)
8433         {
8434           const int len = strlen (type_name);
8435           char *name = (char *) alloca (len + strlen (xa_suffix));
8436
8437           if (type_name[len - 1] == 'P')
8438             {
8439               strcpy (name, type_name);
8440               strcpy (name + len - 1, xa_suffix);
8441               index_type_desc = ada_find_parallel_type_with_name (type0, name);
8442             }
8443         }
8444     }
8445
8446   ada_fixup_array_indexes_type (index_type_desc);
8447   if (index_type_desc != NULL
8448       && ada_is_redundant_index_type_desc (type0, index_type_desc))
8449     {
8450       /* Ignore this ___XA parallel type, as it does not bring any
8451          useful information.  This allows us to avoid creating fixed
8452          versions of the array's index types, which would be identical
8453          to the original ones.  This, in turn, can also help avoid
8454          the creation of fixed versions of the array itself.  */
8455       index_type_desc = NULL;
8456     }
8457
8458   if (index_type_desc == NULL)
8459     {
8460       struct type *elt_type0 = ada_check_typedef (type0->target_type ());
8461
8462       /* NOTE: elt_type---the fixed version of elt_type0---should never
8463          depend on the contents of the array in properly constructed
8464          debugging data.  */
8465       /* Create a fixed version of the array element type.
8466          We're not providing the address of an element here,
8467          and thus the actual object value cannot be inspected to do
8468          the conversion.  This should not be a problem, since arrays of
8469          unconstrained objects are not allowed.  In particular, all
8470          the elements of an array of a tagged type should all be of
8471          the same type specified in the debugging info.  No need to
8472          consult the object tag.  */
8473       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8474
8475       /* Make sure we always create a new array type when dealing with
8476          packed array types, since we're going to fix-up the array
8477          type length and element bitsize a little further down.  */
8478       if (elt_type0 == elt_type && !constrained_packed_array_p)
8479         result = type0;
8480       else
8481         result = create_array_type (alloc_type_copy (type0),
8482                                     elt_type, type0->index_type ());
8483     }
8484   else
8485     {
8486       int i;
8487       struct type *elt_type0;
8488
8489       elt_type0 = type0;
8490       for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8491         elt_type0 = elt_type0->target_type ();
8492
8493       /* NOTE: result---the fixed version of elt_type0---should never
8494          depend on the contents of the array in properly constructed
8495          debugging data.  */
8496       /* Create a fixed version of the array element type.
8497          We're not providing the address of an element here,
8498          and thus the actual object value cannot be inspected to do
8499          the conversion.  This should not be a problem, since arrays of
8500          unconstrained objects are not allowed.  In particular, all
8501          the elements of an array of a tagged type should all be of
8502          the same type specified in the debugging info.  No need to
8503          consult the object tag.  */
8504       result =
8505         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8506
8507       elt_type0 = type0;
8508       for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8509         {
8510           struct type *range_type =
8511             to_fixed_range_type (index_type_desc->field (i).type (), dval);
8512
8513           result = create_array_type (alloc_type_copy (elt_type0),
8514                                       result, range_type);
8515           elt_type0 = elt_type0->target_type ();
8516         }
8517     }
8518
8519   /* We want to preserve the type name.  This can be useful when
8520      trying to get the type name of a value that has already been
8521      printed (for instance, if the user did "print VAR; whatis $".  */
8522   result->set_name (type0->name ());
8523
8524   if (constrained_packed_array_p)
8525     {
8526       /* So far, the resulting type has been created as if the original
8527          type was a regular (non-packed) array type.  As a result, the
8528          bitsize of the array elements needs to be set again, and the array
8529          length needs to be recomputed based on that bitsize.  */
8530       int len = result->length () / result->target_type ()->length ();
8531       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8532
8533       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8534       result->set_length (len * elt_bitsize / HOST_CHAR_BIT);
8535       if (result->length () * HOST_CHAR_BIT < len * elt_bitsize)
8536         result->set_length (result->length () + 1);
8537     }
8538
8539   result->set_is_fixed_instance (true);
8540   return result;
8541 }
8542
8543
8544 /* A standard type (containing no dynamically sized components)
8545    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8546    DVAL describes a record containing any discriminants used in TYPE0,
8547    and may be NULL if there are none, or if the object of type TYPE at
8548    ADDRESS or in VALADDR contains these discriminants.
8549    
8550    If CHECK_TAG is not null, in the case of tagged types, this function
8551    attempts to locate the object's tag and use it to compute the actual
8552    type.  However, when ADDRESS is null, we cannot use it to determine the
8553    location of the tag, and therefore compute the tagged type's actual type.
8554    So we return the tagged type without consulting the tag.  */
8555    
8556 static struct type *
8557 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8558                    CORE_ADDR address, struct value *dval, int check_tag)
8559 {
8560   type = ada_check_typedef (type);
8561
8562   /* Only un-fixed types need to be handled here.  */
8563   if (!HAVE_GNAT_AUX_INFO (type))
8564     return type;
8565
8566   switch (type->code ())
8567     {
8568     default:
8569       return type;
8570     case TYPE_CODE_STRUCT:
8571       {
8572         struct type *static_type = to_static_fixed_type (type);
8573         struct type *fixed_record_type =
8574           to_fixed_record_type (type, valaddr, address, NULL);
8575
8576         /* If STATIC_TYPE is a tagged type and we know the object's address,
8577            then we can determine its tag, and compute the object's actual
8578            type from there.  Note that we have to use the fixed record
8579            type (the parent part of the record may have dynamic fields
8580            and the way the location of _tag is expressed may depend on
8581            them).  */
8582
8583         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8584           {
8585             struct value *tag =
8586               value_tag_from_contents_and_address
8587               (fixed_record_type,
8588                valaddr,
8589                address);
8590             struct type *real_type = type_from_tag (tag);
8591             struct value *obj =
8592               value_from_contents_and_address (fixed_record_type,
8593                                                valaddr,
8594                                                address);
8595             fixed_record_type = value_type (obj);
8596             if (real_type != NULL)
8597               return to_fixed_record_type
8598                 (real_type, NULL,
8599                  value_address (ada_tag_value_at_base_address (obj)), NULL);
8600           }
8601
8602         /* Check to see if there is a parallel ___XVZ variable.
8603            If there is, then it provides the actual size of our type.  */
8604         else if (ada_type_name (fixed_record_type) != NULL)
8605           {
8606             const char *name = ada_type_name (fixed_record_type);
8607             char *xvz_name
8608               = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8609             bool xvz_found = false;
8610             LONGEST size;
8611
8612             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8613             try
8614               {
8615                 xvz_found = get_int_var_value (xvz_name, size);
8616               }
8617             catch (const gdb_exception_error &except)
8618               {
8619                 /* We found the variable, but somehow failed to read
8620                    its value.  Rethrow the same error, but with a little
8621                    bit more information, to help the user understand
8622                    what went wrong (Eg: the variable might have been
8623                    optimized out).  */
8624                 throw_error (except.error,
8625                              _("unable to read value of %s (%s)"),
8626                              xvz_name, except.what ());
8627               }
8628
8629             if (xvz_found && fixed_record_type->length () != size)
8630               {
8631                 fixed_record_type = copy_type (fixed_record_type);
8632                 fixed_record_type->set_length (size);
8633
8634                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
8635                    observed this when the debugging info is STABS, and
8636                    apparently it is something that is hard to fix.
8637
8638                    In practice, we don't need the actual type definition
8639                    at all, because the presence of the XVZ variable allows us
8640                    to assume that there must be a XVS type as well, which we
8641                    should be able to use later, when we need the actual type
8642                    definition.
8643
8644                    In the meantime, pretend that the "fixed" type we are
8645                    returning is NOT a stub, because this can cause trouble
8646                    when using this type to create new types targeting it.
8647                    Indeed, the associated creation routines often check
8648                    whether the target type is a stub and will try to replace
8649                    it, thus using a type with the wrong size.  This, in turn,
8650                    might cause the new type to have the wrong size too.
8651                    Consider the case of an array, for instance, where the size
8652                    of the array is computed from the number of elements in
8653                    our array multiplied by the size of its element.  */
8654                 fixed_record_type->set_is_stub (false);
8655               }
8656           }
8657         return fixed_record_type;
8658       }
8659     case TYPE_CODE_ARRAY:
8660       return to_fixed_array_type (type, dval, 1);
8661     case TYPE_CODE_UNION:
8662       if (dval == NULL)
8663         return type;
8664       else
8665         return to_fixed_variant_branch_type (type, valaddr, address, dval);
8666     }
8667 }
8668
8669 /* The same as ada_to_fixed_type_1, except that it preserves the type
8670    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8671
8672    The typedef layer needs be preserved in order to differentiate between
8673    arrays and array pointers when both types are implemented using the same
8674    fat pointer.  In the array pointer case, the pointer is encoded as
8675    a typedef of the pointer type.  For instance, considering:
8676
8677           type String_Access is access String;
8678           S1 : String_Access := null;
8679
8680    To the debugger, S1 is defined as a typedef of type String.  But
8681    to the user, it is a pointer.  So if the user tries to print S1,
8682    we should not dereference the array, but print the array address
8683    instead.
8684
8685    If we didn't preserve the typedef layer, we would lose the fact that
8686    the type is to be presented as a pointer (needs de-reference before
8687    being printed).  And we would also use the source-level type name.  */
8688
8689 struct type *
8690 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8691                    CORE_ADDR address, struct value *dval, int check_tag)
8692
8693 {
8694   struct type *fixed_type =
8695     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8696
8697   /*  If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8698       then preserve the typedef layer.
8699
8700       Implementation note: We can only check the main-type portion of
8701       the TYPE and FIXED_TYPE, because eliminating the typedef layer
8702       from TYPE now returns a type that has the same instance flags
8703       as TYPE.  For instance, if TYPE is a "typedef const", and its
8704       target type is a "struct", then the typedef elimination will return
8705       a "const" version of the target type.  See check_typedef for more
8706       details about how the typedef layer elimination is done.
8707
8708       brobecker/2010-11-19: It seems to me that the only case where it is
8709       useful to preserve the typedef layer is when dealing with fat pointers.
8710       Perhaps, we could add a check for that and preserve the typedef layer
8711       only in that situation.  But this seems unnecessary so far, probably
8712       because we call check_typedef/ada_check_typedef pretty much everywhere.
8713       */
8714   if (type->code () == TYPE_CODE_TYPEDEF
8715       && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8716           == TYPE_MAIN_TYPE (fixed_type)))
8717     return type;
8718
8719   return fixed_type;
8720 }
8721
8722 /* A standard (static-sized) type corresponding as well as possible to
8723    TYPE0, but based on no runtime data.  */
8724
8725 static struct type *
8726 to_static_fixed_type (struct type *type0)
8727 {
8728   struct type *type;
8729
8730   if (type0 == NULL)
8731     return NULL;
8732
8733   if (type0->is_fixed_instance ())
8734     return type0;
8735
8736   type0 = ada_check_typedef (type0);
8737
8738   switch (type0->code ())
8739     {
8740     default:
8741       return type0;
8742     case TYPE_CODE_STRUCT:
8743       type = dynamic_template_type (type0);
8744       if (type != NULL)
8745         return template_to_static_fixed_type (type);
8746       else
8747         return template_to_static_fixed_type (type0);
8748     case TYPE_CODE_UNION:
8749       type = ada_find_parallel_type (type0, "___XVU");
8750       if (type != NULL)
8751         return template_to_static_fixed_type (type);
8752       else
8753         return template_to_static_fixed_type (type0);
8754     }
8755 }
8756
8757 /* A static approximation of TYPE with all type wrappers removed.  */
8758
8759 static struct type *
8760 static_unwrap_type (struct type *type)
8761 {
8762   if (ada_is_aligner_type (type))
8763     {
8764       struct type *type1 = ada_check_typedef (type)->field (0).type ();
8765       if (ada_type_name (type1) == NULL)
8766         type1->set_name (ada_type_name (type));
8767
8768       return static_unwrap_type (type1);
8769     }
8770   else
8771     {
8772       struct type *raw_real_type = ada_get_base_type (type);
8773
8774       if (raw_real_type == type)
8775         return type;
8776       else
8777         return to_static_fixed_type (raw_real_type);
8778     }
8779 }
8780
8781 /* In some cases, incomplete and private types require
8782    cross-references that are not resolved as records (for example,
8783       type Foo;
8784       type FooP is access Foo;
8785       V: FooP;
8786       type Foo is array ...;
8787    ).  In these cases, since there is no mechanism for producing
8788    cross-references to such types, we instead substitute for FooP a
8789    stub enumeration type that is nowhere resolved, and whose tag is
8790    the name of the actual type.  Call these types "non-record stubs".  */
8791
8792 /* A type equivalent to TYPE that is not a non-record stub, if one
8793    exists, otherwise TYPE.  */
8794
8795 struct type *
8796 ada_check_typedef (struct type *type)
8797 {
8798   if (type == NULL)
8799     return NULL;
8800
8801   /* If our type is an access to an unconstrained array, which is encoded
8802      as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8803      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8804      what allows us to distinguish between fat pointers that represent
8805      array types, and fat pointers that represent array access types
8806      (in both cases, the compiler implements them as fat pointers).  */
8807   if (ada_is_access_to_unconstrained_array (type))
8808     return type;
8809
8810   type = check_typedef (type);
8811   if (type == NULL || type->code () != TYPE_CODE_ENUM
8812       || !type->is_stub ()
8813       || type->name () == NULL)
8814     return type;
8815   else
8816     {
8817       const char *name = type->name ();
8818       struct type *type1 = ada_find_any_type (name);
8819
8820       if (type1 == NULL)
8821         return type;
8822
8823       /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8824          stubs pointing to arrays, as we don't create symbols for array
8825          types, only for the typedef-to-array types).  If that's the case,
8826          strip the typedef layer.  */
8827       if (type1->code () == TYPE_CODE_TYPEDEF)
8828         type1 = ada_check_typedef (type1);
8829
8830       return type1;
8831     }
8832 }
8833
8834 /* A value representing the data at VALADDR/ADDRESS as described by
8835    type TYPE0, but with a standard (static-sized) type that correctly
8836    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
8837    type, then return VAL0 [this feature is simply to avoid redundant
8838    creation of struct values].  */
8839
8840 static struct value *
8841 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8842                            struct value *val0)
8843 {
8844   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8845
8846   if (type == type0 && val0 != NULL)
8847     return val0;
8848
8849   if (VALUE_LVAL (val0) != lval_memory)
8850     {
8851       /* Our value does not live in memory; it could be a convenience
8852          variable, for instance.  Create a not_lval value using val0's
8853          contents.  */
8854       return value_from_contents (type, value_contents (val0).data ());
8855     }
8856
8857   return value_from_contents_and_address (type, 0, address);
8858 }
8859
8860 /* A value representing VAL, but with a standard (static-sized) type
8861    that correctly describes it.  Does not necessarily create a new
8862    value.  */
8863
8864 struct value *
8865 ada_to_fixed_value (struct value *val)
8866 {
8867   val = unwrap_value (val);
8868   val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8869   return val;
8870 }
8871 \f
8872
8873 /* Attributes */
8874
8875 /* Table mapping attribute numbers to names.
8876    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
8877
8878 static const char * const attribute_names[] = {
8879   "<?>",
8880
8881   "first",
8882   "last",
8883   "length",
8884   "image",
8885   "max",
8886   "min",
8887   "modulus",
8888   "pos",
8889   "size",
8890   "tag",
8891   "val",
8892   0
8893 };
8894
8895 static const char *
8896 ada_attribute_name (enum exp_opcode n)
8897 {
8898   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8899     return attribute_names[n - OP_ATR_FIRST + 1];
8900   else
8901     return attribute_names[0];
8902 }
8903
8904 /* Evaluate the 'POS attribute applied to ARG.  */
8905
8906 static LONGEST
8907 pos_atr (struct value *arg)
8908 {
8909   struct value *val = coerce_ref (arg);
8910   struct type *type = value_type (val);
8911
8912   if (!discrete_type_p (type))
8913     error (_("'POS only defined on discrete types"));
8914
8915   gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8916   if (!result.has_value ())
8917     error (_("enumeration value is invalid: can't find 'POS"));
8918
8919   return *result;
8920 }
8921
8922 struct value *
8923 ada_pos_atr (struct type *expect_type,
8924              struct expression *exp,
8925              enum noside noside, enum exp_opcode op,
8926              struct value *arg)
8927 {
8928   struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8929   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8930     return value_zero (type, not_lval);
8931   return value_from_longest (type, pos_atr (arg));
8932 }
8933
8934 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
8935
8936 static struct value *
8937 val_atr (struct type *type, LONGEST val)
8938 {
8939   gdb_assert (discrete_type_p (type));
8940   if (type->code () == TYPE_CODE_RANGE)
8941     type = type->target_type ();
8942   if (type->code () == TYPE_CODE_ENUM)
8943     {
8944       if (val < 0 || val >= type->num_fields ())
8945         error (_("argument to 'VAL out of range"));
8946       val = type->field (val).loc_enumval ();
8947     }
8948   return value_from_longest (type, val);
8949 }
8950
8951 struct value *
8952 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8953 {
8954   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8955     return value_zero (type, not_lval);
8956
8957   if (!discrete_type_p (type))
8958     error (_("'VAL only defined on discrete types"));
8959   if (!integer_type_p (value_type (arg)))
8960     error (_("'VAL requires integral argument"));
8961
8962   return val_atr (type, value_as_long (arg));
8963 }
8964 \f
8965
8966                                 /* Evaluation */
8967
8968 /* True if TYPE appears to be an Ada character type.
8969    [At the moment, this is true only for Character and Wide_Character;
8970    It is a heuristic test that could stand improvement].  */
8971
8972 bool
8973 ada_is_character_type (struct type *type)
8974 {
8975   const char *name;
8976
8977   /* If the type code says it's a character, then assume it really is,
8978      and don't check any further.  */
8979   if (type->code () == TYPE_CODE_CHAR)
8980     return true;
8981   
8982   /* Otherwise, assume it's a character type iff it is a discrete type
8983      with a known character type name.  */
8984   name = ada_type_name (type);
8985   return (name != NULL
8986           && (type->code () == TYPE_CODE_INT
8987               || type->code () == TYPE_CODE_RANGE)
8988           && (strcmp (name, "character") == 0
8989               || strcmp (name, "wide_character") == 0
8990               || strcmp (name, "wide_wide_character") == 0
8991               || strcmp (name, "unsigned char") == 0));
8992 }
8993
8994 /* True if TYPE appears to be an Ada string type.  */
8995
8996 bool
8997 ada_is_string_type (struct type *type)
8998 {
8999   type = ada_check_typedef (type);
9000   if (type != NULL
9001       && type->code () != TYPE_CODE_PTR
9002       && (ada_is_simple_array_type (type)
9003           || ada_is_array_descriptor_type (type))
9004       && ada_array_arity (type) == 1)
9005     {
9006       struct type *elttype = ada_array_element_type (type, 1);
9007
9008       return ada_is_character_type (elttype);
9009     }
9010   else
9011     return false;
9012 }
9013
9014 /* The compiler sometimes provides a parallel XVS type for a given
9015    PAD type.  Normally, it is safe to follow the PAD type directly,
9016    but older versions of the compiler have a bug that causes the offset
9017    of its "F" field to be wrong.  Following that field in that case
9018    would lead to incorrect results, but this can be worked around
9019    by ignoring the PAD type and using the associated XVS type instead.
9020
9021    Set to True if the debugger should trust the contents of PAD types.
9022    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
9023 static bool trust_pad_over_xvs = true;
9024
9025 /* True if TYPE is a struct type introduced by the compiler to force the
9026    alignment of a value.  Such types have a single field with a
9027    distinctive name.  */
9028
9029 int
9030 ada_is_aligner_type (struct type *type)
9031 {
9032   type = ada_check_typedef (type);
9033
9034   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9035     return 0;
9036
9037   return (type->code () == TYPE_CODE_STRUCT
9038           && type->num_fields () == 1
9039           && strcmp (type->field (0).name (), "F") == 0);
9040 }
9041
9042 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9043    the parallel type.  */
9044
9045 struct type *
9046 ada_get_base_type (struct type *raw_type)
9047 {
9048   struct type *real_type_namer;
9049   struct type *raw_real_type;
9050
9051   if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
9052     return raw_type;
9053
9054   if (ada_is_aligner_type (raw_type))
9055     /* The encoding specifies that we should always use the aligner type.
9056        So, even if this aligner type has an associated XVS type, we should
9057        simply ignore it.
9058
9059        According to the compiler gurus, an XVS type parallel to an aligner
9060        type may exist because of a stabs limitation.  In stabs, aligner
9061        types are empty because the field has a variable-sized type, and
9062        thus cannot actually be used as an aligner type.  As a result,
9063        we need the associated parallel XVS type to decode the type.
9064        Since the policy in the compiler is to not change the internal
9065        representation based on the debugging info format, we sometimes
9066        end up having a redundant XVS type parallel to the aligner type.  */
9067     return raw_type;
9068
9069   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9070   if (real_type_namer == NULL
9071       || real_type_namer->code () != TYPE_CODE_STRUCT
9072       || real_type_namer->num_fields () != 1)
9073     return raw_type;
9074
9075   if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
9076     {
9077       /* This is an older encoding form where the base type needs to be
9078          looked up by name.  We prefer the newer encoding because it is
9079          more efficient.  */
9080       raw_real_type = ada_find_any_type (real_type_namer->field (0).name ());
9081       if (raw_real_type == NULL)
9082         return raw_type;
9083       else
9084         return raw_real_type;
9085     }
9086
9087   /* The field in our XVS type is a reference to the base type.  */
9088   return real_type_namer->field (0).type ()->target_type ();
9089 }
9090
9091 /* The type of value designated by TYPE, with all aligners removed.  */
9092
9093 struct type *
9094 ada_aligned_type (struct type *type)
9095 {
9096   if (ada_is_aligner_type (type))
9097     return ada_aligned_type (type->field (0).type ());
9098   else
9099     return ada_get_base_type (type);
9100 }
9101
9102
9103 /* The address of the aligned value in an object at address VALADDR
9104    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
9105
9106 const gdb_byte *
9107 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9108 {
9109   if (ada_is_aligner_type (type))
9110     return ada_aligned_value_addr
9111       (type->field (0).type (),
9112        valaddr + type->field (0).loc_bitpos () / TARGET_CHAR_BIT);
9113   else
9114     return valaddr;
9115 }
9116
9117
9118
9119 /* The printed representation of an enumeration literal with encoded
9120    name NAME.  The value is good to the next call of ada_enum_name.  */
9121 const char *
9122 ada_enum_name (const char *name)
9123 {
9124   static std::string storage;
9125   const char *tmp;
9126
9127   /* First, unqualify the enumeration name:
9128      1. Search for the last '.' character.  If we find one, then skip
9129      all the preceding characters, the unqualified name starts
9130      right after that dot.
9131      2. Otherwise, we may be debugging on a target where the compiler
9132      translates dots into "__".  Search forward for double underscores,
9133      but stop searching when we hit an overloading suffix, which is
9134      of the form "__" followed by digits.  */
9135
9136   tmp = strrchr (name, '.');
9137   if (tmp != NULL)
9138     name = tmp + 1;
9139   else
9140     {
9141       while ((tmp = strstr (name, "__")) != NULL)
9142         {
9143           if (isdigit (tmp[2]))
9144             break;
9145           else
9146             name = tmp + 2;
9147         }
9148     }
9149
9150   if (name[0] == 'Q')
9151     {
9152       int v;
9153
9154       if (name[1] == 'U' || name[1] == 'W')
9155         {
9156           int offset = 2;
9157           if (name[1] == 'W' && name[2] == 'W')
9158             {
9159               /* Also handle the QWW case.  */
9160               ++offset;
9161             }
9162           if (sscanf (name + offset, "%x", &v) != 1)
9163             return name;
9164         }
9165       else if (((name[1] >= '0' && name[1] <= '9')
9166                 || (name[1] >= 'a' && name[1] <= 'z'))
9167                && name[2] == '\0')
9168         {
9169           storage = string_printf ("'%c'", name[1]);
9170           return storage.c_str ();
9171         }
9172       else
9173         return name;
9174
9175       if (isascii (v) && isprint (v))
9176         storage = string_printf ("'%c'", v);
9177       else if (name[1] == 'U')
9178         storage = string_printf ("'[\"%02x\"]'", v);
9179       else if (name[2] != 'W')
9180         storage = string_printf ("'[\"%04x\"]'", v);
9181       else
9182         storage = string_printf ("'[\"%06x\"]'", v);
9183
9184       return storage.c_str ();
9185     }
9186   else
9187     {
9188       tmp = strstr (name, "__");
9189       if (tmp == NULL)
9190         tmp = strstr (name, "$");
9191       if (tmp != NULL)
9192         {
9193           storage = std::string (name, tmp - name);
9194           return storage.c_str ();
9195         }
9196
9197       return name;
9198     }
9199 }
9200
9201 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9202    value it wraps.  */
9203
9204 static struct value *
9205 unwrap_value (struct value *val)
9206 {
9207   struct type *type = ada_check_typedef (value_type (val));
9208
9209   if (ada_is_aligner_type (type))
9210     {
9211       struct value *v = ada_value_struct_elt (val, "F", 0);
9212       struct type *val_type = ada_check_typedef (value_type (v));
9213
9214       if (ada_type_name (val_type) == NULL)
9215         val_type->set_name (ada_type_name (type));
9216
9217       return unwrap_value (v);
9218     }
9219   else
9220     {
9221       struct type *raw_real_type =
9222         ada_check_typedef (ada_get_base_type (type));
9223
9224       /* If there is no parallel XVS or XVE type, then the value is
9225          already unwrapped.  Return it without further modification.  */
9226       if ((type == raw_real_type)
9227           && ada_find_parallel_type (type, "___XVE") == NULL)
9228         return val;
9229
9230       return
9231         coerce_unspec_val_to_type
9232         (val, ada_to_fixed_type (raw_real_type, 0,
9233                                  value_address (val),
9234                                  NULL, 1));
9235     }
9236 }
9237
9238 /* Given two array types T1 and T2, return nonzero iff both arrays
9239    contain the same number of elements.  */
9240
9241 static int
9242 ada_same_array_size_p (struct type *t1, struct type *t2)
9243 {
9244   LONGEST lo1, hi1, lo2, hi2;
9245
9246   /* Get the array bounds in order to verify that the size of
9247      the two arrays match.  */
9248   if (!get_array_bounds (t1, &lo1, &hi1)
9249       || !get_array_bounds (t2, &lo2, &hi2))
9250     error (_("unable to determine array bounds"));
9251
9252   /* To make things easier for size comparison, normalize a bit
9253      the case of empty arrays by making sure that the difference
9254      between upper bound and lower bound is always -1.  */
9255   if (lo1 > hi1)
9256     hi1 = lo1 - 1;
9257   if (lo2 > hi2)
9258     hi2 = lo2 - 1;
9259
9260   return (hi1 - lo1 == hi2 - lo2);
9261 }
9262
9263 /* Assuming that VAL is an array of integrals, and TYPE represents
9264    an array with the same number of elements, but with wider integral
9265    elements, return an array "casted" to TYPE.  In practice, this
9266    means that the returned array is built by casting each element
9267    of the original array into TYPE's (wider) element type.  */
9268
9269 static struct value *
9270 ada_promote_array_of_integrals (struct type *type, struct value *val)
9271 {
9272   struct type *elt_type = type->target_type ();
9273   LONGEST lo, hi;
9274   LONGEST i;
9275
9276   /* Verify that both val and type are arrays of scalars, and
9277      that the size of val's elements is smaller than the size
9278      of type's element.  */
9279   gdb_assert (type->code () == TYPE_CODE_ARRAY);
9280   gdb_assert (is_integral_type (type->target_type ()));
9281   gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
9282   gdb_assert (is_integral_type (value_type (val)->target_type ()));
9283   gdb_assert (type->target_type ()->length ()
9284               > value_type (val)->target_type ()->length ());
9285
9286   if (!get_array_bounds (type, &lo, &hi))
9287     error (_("unable to determine array bounds"));
9288
9289   value *res = allocate_value (type);
9290   gdb::array_view<gdb_byte> res_contents = value_contents_writeable (res);
9291
9292   /* Promote each array element.  */
9293   for (i = 0; i < hi - lo + 1; i++)
9294     {
9295       struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9296       int elt_len = elt_type->length ();
9297
9298       copy (value_contents_all (elt), res_contents.slice (elt_len * i, elt_len));
9299     }
9300
9301   return res;
9302 }
9303
9304 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9305    return the converted value.  */
9306
9307 static struct value *
9308 coerce_for_assign (struct type *type, struct value *val)
9309 {
9310   struct type *type2 = value_type (val);
9311
9312   if (type == type2)
9313     return val;
9314
9315   type2 = ada_check_typedef (type2);
9316   type = ada_check_typedef (type);
9317
9318   if (type2->code () == TYPE_CODE_PTR
9319       && type->code () == TYPE_CODE_ARRAY)
9320     {
9321       val = ada_value_ind (val);
9322       type2 = value_type (val);
9323     }
9324
9325   if (type2->code () == TYPE_CODE_ARRAY
9326       && type->code () == TYPE_CODE_ARRAY)
9327     {
9328       if (!ada_same_array_size_p (type, type2))
9329         error (_("cannot assign arrays of different length"));
9330
9331       if (is_integral_type (type->target_type ())
9332           && is_integral_type (type2->target_type ())
9333           && type2->target_type ()->length () < type->target_type ()->length ())
9334         {
9335           /* Allow implicit promotion of the array elements to
9336              a wider type.  */
9337           return ada_promote_array_of_integrals (type, val);
9338         }
9339
9340       if (type2->target_type ()->length () != type->target_type ()->length ())
9341         error (_("Incompatible types in assignment"));
9342       deprecated_set_value_type (val, type);
9343     }
9344   return val;
9345 }
9346
9347 static struct value *
9348 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9349 {
9350   struct value *val;
9351   struct type *type1, *type2;
9352   LONGEST v, v1, v2;
9353
9354   arg1 = coerce_ref (arg1);
9355   arg2 = coerce_ref (arg2);
9356   type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9357   type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9358
9359   if (type1->code () != TYPE_CODE_INT
9360       || type2->code () != TYPE_CODE_INT)
9361     return value_binop (arg1, arg2, op);
9362
9363   switch (op)
9364     {
9365     case BINOP_MOD:
9366     case BINOP_DIV:
9367     case BINOP_REM:
9368       break;
9369     default:
9370       return value_binop (arg1, arg2, op);
9371     }
9372
9373   v2 = value_as_long (arg2);
9374   if (v2 == 0)
9375     {
9376       const char *name;
9377       if (op == BINOP_MOD)
9378         name = "mod";
9379       else if (op == BINOP_DIV)
9380         name = "/";
9381       else
9382         {
9383           gdb_assert (op == BINOP_REM);
9384           name = "rem";
9385         }
9386
9387       error (_("second operand of %s must not be zero."), name);
9388     }
9389
9390   if (type1->is_unsigned () || op == BINOP_MOD)
9391     return value_binop (arg1, arg2, op);
9392
9393   v1 = value_as_long (arg1);
9394   switch (op)
9395     {
9396     case BINOP_DIV:
9397       v = v1 / v2;
9398       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9399         v += v > 0 ? -1 : 1;
9400       break;
9401     case BINOP_REM:
9402       v = v1 % v2;
9403       if (v * v1 < 0)
9404         v -= v2;
9405       break;
9406     default:
9407       /* Should not reach this point.  */
9408       v = 0;
9409     }
9410
9411   val = allocate_value (type1);
9412   store_unsigned_integer (value_contents_raw (val).data (),
9413                           value_type (val)->length (),
9414                           type_byte_order (type1), v);
9415   return val;
9416 }
9417
9418 static int
9419 ada_value_equal (struct value *arg1, struct value *arg2)
9420 {
9421   if (ada_is_direct_array_type (value_type (arg1))
9422       || ada_is_direct_array_type (value_type (arg2)))
9423     {
9424       struct type *arg1_type, *arg2_type;
9425
9426       /* Automatically dereference any array reference before
9427          we attempt to perform the comparison.  */
9428       arg1 = ada_coerce_ref (arg1);
9429       arg2 = ada_coerce_ref (arg2);
9430
9431       arg1 = ada_coerce_to_simple_array (arg1);
9432       arg2 = ada_coerce_to_simple_array (arg2);
9433
9434       arg1_type = ada_check_typedef (value_type (arg1));
9435       arg2_type = ada_check_typedef (value_type (arg2));
9436
9437       if (arg1_type->code () != TYPE_CODE_ARRAY
9438           || arg2_type->code () != TYPE_CODE_ARRAY)
9439         error (_("Attempt to compare array with non-array"));
9440       /* FIXME: The following works only for types whose
9441          representations use all bits (no padding or undefined bits)
9442          and do not have user-defined equality.  */
9443       return (arg1_type->length () == arg2_type->length ()
9444               && memcmp (value_contents (arg1).data (),
9445                          value_contents (arg2).data (),
9446                          arg1_type->length ()) == 0);
9447     }
9448   return value_equal (arg1, arg2);
9449 }
9450
9451 namespace expr
9452 {
9453
9454 bool
9455 check_objfile (const std::unique_ptr<ada_component> &comp,
9456                struct objfile *objfile)
9457 {
9458   return comp->uses_objfile (objfile);
9459 }
9460
9461 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9462    component of LHS (a simple array or a record).  Does not modify the
9463    inferior's memory, nor does it modify LHS (unless LHS ==
9464    CONTAINER).  */
9465
9466 static void
9467 assign_component (struct value *container, struct value *lhs, LONGEST index,
9468                   struct expression *exp, operation_up &arg)
9469 {
9470   scoped_value_mark mark;
9471
9472   struct value *elt;
9473   struct type *lhs_type = check_typedef (value_type (lhs));
9474
9475   if (lhs_type->code () == TYPE_CODE_ARRAY)
9476     {
9477       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9478       struct value *index_val = value_from_longest (index_type, index);
9479
9480       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9481     }
9482   else
9483     {
9484       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9485       elt = ada_to_fixed_value (elt);
9486     }
9487
9488   ada_aggregate_operation *ag_op
9489     = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9490   if (ag_op != nullptr)
9491     ag_op->assign_aggregate (container, elt, exp);
9492   else
9493     value_assign_to_component (container, elt,
9494                                arg->evaluate (nullptr, exp,
9495                                               EVAL_NORMAL));
9496 }
9497
9498 bool
9499 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9500 {
9501   for (const auto &item : m_components)
9502     if (item->uses_objfile (objfile))
9503       return true;
9504   return false;
9505 }
9506
9507 void
9508 ada_aggregate_component::dump (ui_file *stream, int depth)
9509 {
9510   gdb_printf (stream, _("%*sAggregate\n"), depth, "");
9511   for (const auto &item : m_components)
9512     item->dump (stream, depth + 1);
9513 }
9514
9515 void
9516 ada_aggregate_component::assign (struct value *container,
9517                                  struct value *lhs, struct expression *exp,
9518                                  std::vector<LONGEST> &indices,
9519                                  LONGEST low, LONGEST high)
9520 {
9521   for (auto &item : m_components)
9522     item->assign (container, lhs, exp, indices, low, high);
9523 }
9524
9525 /* See ada-exp.h.  */
9526
9527 value *
9528 ada_aggregate_operation::assign_aggregate (struct value *container,
9529                                            struct value *lhs,
9530                                            struct expression *exp)
9531 {
9532   struct type *lhs_type;
9533   LONGEST low_index, high_index;
9534
9535   container = ada_coerce_ref (container);
9536   if (ada_is_direct_array_type (value_type (container)))
9537     container = ada_coerce_to_simple_array (container);
9538   lhs = ada_coerce_ref (lhs);
9539   if (!deprecated_value_modifiable (lhs))
9540     error (_("Left operand of assignment is not a modifiable lvalue."));
9541
9542   lhs_type = check_typedef (value_type (lhs));
9543   if (ada_is_direct_array_type (lhs_type))
9544     {
9545       lhs = ada_coerce_to_simple_array (lhs);
9546       lhs_type = check_typedef (value_type (lhs));
9547       low_index = lhs_type->bounds ()->low.const_val ();
9548       high_index = lhs_type->bounds ()->high.const_val ();
9549     }
9550   else if (lhs_type->code () == TYPE_CODE_STRUCT)
9551     {
9552       low_index = 0;
9553       high_index = num_visible_fields (lhs_type) - 1;
9554     }
9555   else
9556     error (_("Left-hand side must be array or record."));
9557
9558   std::vector<LONGEST> indices (4);
9559   indices[0] = indices[1] = low_index - 1;
9560   indices[2] = indices[3] = high_index + 1;
9561
9562   std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9563                                    low_index, high_index);
9564
9565   return container;
9566 }
9567
9568 bool
9569 ada_positional_component::uses_objfile (struct objfile *objfile)
9570 {
9571   return m_op->uses_objfile (objfile);
9572 }
9573
9574 void
9575 ada_positional_component::dump (ui_file *stream, int depth)
9576 {
9577   gdb_printf (stream, _("%*sPositional, index = %d\n"),
9578               depth, "", m_index);
9579   m_op->dump (stream, depth + 1);
9580 }
9581
9582 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9583    construct, given that the positions are relative to lower bound
9584    LOW, where HIGH is the upper bound.  Record the position in
9585    INDICES.  CONTAINER is as for assign_aggregate.  */
9586 void
9587 ada_positional_component::assign (struct value *container,
9588                                   struct value *lhs, struct expression *exp,
9589                                   std::vector<LONGEST> &indices,
9590                                   LONGEST low, LONGEST high)
9591 {
9592   LONGEST ind = m_index + low;
9593
9594   if (ind - 1 == high)
9595     warning (_("Extra components in aggregate ignored."));
9596   if (ind <= high)
9597     {
9598       add_component_interval (ind, ind, indices);
9599       assign_component (container, lhs, ind, exp, m_op);
9600     }
9601 }
9602
9603 bool
9604 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9605 {
9606   return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9607 }
9608
9609 void
9610 ada_discrete_range_association::dump (ui_file *stream, int depth)
9611 {
9612   gdb_printf (stream, _("%*sDiscrete range:\n"), depth, "");
9613   m_low->dump (stream, depth + 1);
9614   m_high->dump (stream, depth + 1);
9615 }
9616
9617 void
9618 ada_discrete_range_association::assign (struct value *container,
9619                                         struct value *lhs,
9620                                         struct expression *exp,
9621                                         std::vector<LONGEST> &indices,
9622                                         LONGEST low, LONGEST high,
9623                                         operation_up &op)
9624 {
9625   LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9626   LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9627
9628   if (lower <= upper && (lower < low || upper > high))
9629     error (_("Index in component association out of bounds."));
9630
9631   add_component_interval (lower, upper, indices);
9632   while (lower <= upper)
9633     {
9634       assign_component (container, lhs, lower, exp, op);
9635       lower += 1;
9636     }
9637 }
9638
9639 bool
9640 ada_name_association::uses_objfile (struct objfile *objfile)
9641 {
9642   return m_val->uses_objfile (objfile);
9643 }
9644
9645 void
9646 ada_name_association::dump (ui_file *stream, int depth)
9647 {
9648   gdb_printf (stream, _("%*sName:\n"), depth, "");
9649   m_val->dump (stream, depth + 1);
9650 }
9651
9652 void
9653 ada_name_association::assign (struct value *container,
9654                               struct value *lhs,
9655                               struct expression *exp,
9656                               std::vector<LONGEST> &indices,
9657                               LONGEST low, LONGEST high,
9658                               operation_up &op)
9659 {
9660   int index;
9661
9662   if (ada_is_direct_array_type (value_type (lhs)))
9663     index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9664                                                             EVAL_NORMAL)));
9665   else
9666     {
9667       ada_string_operation *strop
9668         = dynamic_cast<ada_string_operation *> (m_val.get ());
9669
9670       const char *name;
9671       if (strop != nullptr)
9672         name = strop->get_name ();
9673       else
9674         {
9675           ada_var_value_operation *vvo
9676             = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9677           if (vvo != nullptr)
9678             error (_("Invalid record component association."));
9679           name = vvo->get_symbol ()->natural_name ();
9680         }
9681
9682       index = 0;
9683       if (! find_struct_field (name, value_type (lhs), 0,
9684                                NULL, NULL, NULL, NULL, &index))
9685         error (_("Unknown component name: %s."), name);
9686     }
9687
9688   add_component_interval (index, index, indices);
9689   assign_component (container, lhs, index, exp, op);
9690 }
9691
9692 bool
9693 ada_choices_component::uses_objfile (struct objfile *objfile)
9694 {
9695   if (m_op->uses_objfile (objfile))
9696     return true;
9697   for (const auto &item : m_assocs)
9698     if (item->uses_objfile (objfile))
9699       return true;
9700   return false;
9701 }
9702
9703 void
9704 ada_choices_component::dump (ui_file *stream, int depth)
9705 {
9706   gdb_printf (stream, _("%*sChoices:\n"), depth, "");
9707   m_op->dump (stream, depth + 1);
9708   for (const auto &item : m_assocs)
9709     item->dump (stream, depth + 1);
9710 }
9711
9712 /* Assign into the components of LHS indexed by the OP_CHOICES
9713    construct at *POS, updating *POS past the construct, given that
9714    the allowable indices are LOW..HIGH.  Record the indices assigned
9715    to in INDICES.  CONTAINER is as for assign_aggregate.  */
9716 void
9717 ada_choices_component::assign (struct value *container,
9718                                struct value *lhs, struct expression *exp,
9719                                std::vector<LONGEST> &indices,
9720                                LONGEST low, LONGEST high)
9721 {
9722   for (auto &item : m_assocs)
9723     item->assign (container, lhs, exp, indices, low, high, m_op);
9724 }
9725
9726 bool
9727 ada_others_component::uses_objfile (struct objfile *objfile)
9728 {
9729   return m_op->uses_objfile (objfile);
9730 }
9731
9732 void
9733 ada_others_component::dump (ui_file *stream, int depth)
9734 {
9735   gdb_printf (stream, _("%*sOthers:\n"), depth, "");
9736   m_op->dump (stream, depth + 1);
9737 }
9738
9739 /* Assign the value of the expression in the OP_OTHERS construct in
9740    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9741    have not been previously assigned.  The index intervals already assigned
9742    are in INDICES.  CONTAINER is as for assign_aggregate.  */
9743 void
9744 ada_others_component::assign (struct value *container,
9745                               struct value *lhs, struct expression *exp,
9746                               std::vector<LONGEST> &indices,
9747                               LONGEST low, LONGEST high)
9748 {
9749   int num_indices = indices.size ();
9750   for (int i = 0; i < num_indices - 2; i += 2)
9751     {
9752       for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9753         assign_component (container, lhs, ind, exp, m_op);
9754     }
9755 }
9756
9757 struct value *
9758 ada_assign_operation::evaluate (struct type *expect_type,
9759                                 struct expression *exp,
9760                                 enum noside noside)
9761 {
9762   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9763
9764   ada_aggregate_operation *ag_op
9765     = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9766   if (ag_op != nullptr)
9767     {
9768       if (noside != EVAL_NORMAL)
9769         return arg1;
9770
9771       arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9772       return ada_value_assign (arg1, arg1);
9773     }
9774   /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9775      except if the lhs of our assignment is a convenience variable.
9776      In the case of assigning to a convenience variable, the lhs
9777      should be exactly the result of the evaluation of the rhs.  */
9778   struct type *type = value_type (arg1);
9779   if (VALUE_LVAL (arg1) == lval_internalvar)
9780     type = NULL;
9781   value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9782   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9783     return arg1;
9784   if (VALUE_LVAL (arg1) == lval_internalvar)
9785     {
9786       /* Nothing.  */
9787     }
9788   else
9789     arg2 = coerce_for_assign (value_type (arg1), arg2);
9790   return ada_value_assign (arg1, arg2);
9791 }
9792
9793 } /* namespace expr */
9794
9795 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9796    [ INDICES[0] .. INDICES[1] ],...  The resulting intervals do not
9797    overlap.  */
9798 static void
9799 add_component_interval (LONGEST low, LONGEST high, 
9800                         std::vector<LONGEST> &indices)
9801 {
9802   int i, j;
9803
9804   int size = indices.size ();
9805   for (i = 0; i < size; i += 2) {
9806     if (high >= indices[i] && low <= indices[i + 1])
9807       {
9808         int kh;
9809
9810         for (kh = i + 2; kh < size; kh += 2)
9811           if (high < indices[kh])
9812             break;
9813         if (low < indices[i])
9814           indices[i] = low;
9815         indices[i + 1] = indices[kh - 1];
9816         if (high > indices[i + 1])
9817           indices[i + 1] = high;
9818         memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9819         indices.resize (kh - i - 2);
9820         return;
9821       }
9822     else if (high < indices[i])
9823       break;
9824   }
9825         
9826   indices.resize (indices.size () + 2);
9827   for (j = indices.size () - 1; j >= i + 2; j -= 1)
9828     indices[j] = indices[j - 2];
9829   indices[i] = low;
9830   indices[i + 1] = high;
9831 }
9832
9833 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9834    is different.  */
9835
9836 static struct value *
9837 ada_value_cast (struct type *type, struct value *arg2)
9838 {
9839   if (type == ada_check_typedef (value_type (arg2)))
9840     return arg2;
9841
9842   return value_cast (type, arg2);
9843 }
9844
9845 /*  Evaluating Ada expressions, and printing their result.
9846     ------------------------------------------------------
9847
9848     1. Introduction:
9849     ----------------
9850
9851     We usually evaluate an Ada expression in order to print its value.
9852     We also evaluate an expression in order to print its type, which
9853     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9854     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
9855     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9856     the evaluation compared to the EVAL_NORMAL, but is otherwise very
9857     similar.
9858
9859     Evaluating expressions is a little more complicated for Ada entities
9860     than it is for entities in languages such as C.  The main reason for
9861     this is that Ada provides types whose definition might be dynamic.
9862     One example of such types is variant records.  Or another example
9863     would be an array whose bounds can only be known at run time.
9864
9865     The following description is a general guide as to what should be
9866     done (and what should NOT be done) in order to evaluate an expression
9867     involving such types, and when.  This does not cover how the semantic
9868     information is encoded by GNAT as this is covered separatly.  For the
9869     document used as the reference for the GNAT encoding, see exp_dbug.ads
9870     in the GNAT sources.
9871
9872     Ideally, we should embed each part of this description next to its
9873     associated code.  Unfortunately, the amount of code is so vast right
9874     now that it's hard to see whether the code handling a particular
9875     situation might be duplicated or not.  One day, when the code is
9876     cleaned up, this guide might become redundant with the comments
9877     inserted in the code, and we might want to remove it.
9878
9879     2. ``Fixing'' an Entity, the Simple Case:
9880     -----------------------------------------
9881
9882     When evaluating Ada expressions, the tricky issue is that they may
9883     reference entities whose type contents and size are not statically
9884     known.  Consider for instance a variant record:
9885
9886        type Rec (Empty : Boolean := True) is record
9887           case Empty is
9888              when True => null;
9889              when False => Value : Integer;
9890           end case;
9891        end record;
9892        Yes : Rec := (Empty => False, Value => 1);
9893        No  : Rec := (empty => True);
9894
9895     The size and contents of that record depends on the value of the
9896     descriminant (Rec.Empty).  At this point, neither the debugging
9897     information nor the associated type structure in GDB are able to
9898     express such dynamic types.  So what the debugger does is to create
9899     "fixed" versions of the type that applies to the specific object.
9900     We also informally refer to this operation as "fixing" an object,
9901     which means creating its associated fixed type.
9902
9903     Example: when printing the value of variable "Yes" above, its fixed
9904     type would look like this:
9905
9906        type Rec is record
9907           Empty : Boolean;
9908           Value : Integer;
9909        end record;
9910
9911     On the other hand, if we printed the value of "No", its fixed type
9912     would become:
9913
9914        type Rec is record
9915           Empty : Boolean;
9916        end record;
9917
9918     Things become a little more complicated when trying to fix an entity
9919     with a dynamic type that directly contains another dynamic type,
9920     such as an array of variant records, for instance.  There are
9921     two possible cases: Arrays, and records.
9922
9923     3. ``Fixing'' Arrays:
9924     ---------------------
9925
9926     The type structure in GDB describes an array in terms of its bounds,
9927     and the type of its elements.  By design, all elements in the array
9928     have the same type and we cannot represent an array of variant elements
9929     using the current type structure in GDB.  When fixing an array,
9930     we cannot fix the array element, as we would potentially need one
9931     fixed type per element of the array.  As a result, the best we can do
9932     when fixing an array is to produce an array whose bounds and size
9933     are correct (allowing us to read it from memory), but without having
9934     touched its element type.  Fixing each element will be done later,
9935     when (if) necessary.
9936
9937     Arrays are a little simpler to handle than records, because the same
9938     amount of memory is allocated for each element of the array, even if
9939     the amount of space actually used by each element differs from element
9940     to element.  Consider for instance the following array of type Rec:
9941
9942        type Rec_Array is array (1 .. 2) of Rec;
9943
9944     The actual amount of memory occupied by each element might be different
9945     from element to element, depending on the value of their discriminant.
9946     But the amount of space reserved for each element in the array remains
9947     fixed regardless.  So we simply need to compute that size using
9948     the debugging information available, from which we can then determine
9949     the array size (we multiply the number of elements of the array by
9950     the size of each element).
9951
9952     The simplest case is when we have an array of a constrained element
9953     type. For instance, consider the following type declarations:
9954
9955         type Bounded_String (Max_Size : Integer) is
9956            Length : Integer;
9957            Buffer : String (1 .. Max_Size);
9958         end record;
9959         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9960
9961     In this case, the compiler describes the array as an array of
9962     variable-size elements (identified by its XVS suffix) for which
9963     the size can be read in the parallel XVZ variable.
9964
9965     In the case of an array of an unconstrained element type, the compiler
9966     wraps the array element inside a private PAD type.  This type should not
9967     be shown to the user, and must be "unwrap"'ed before printing.  Note
9968     that we also use the adjective "aligner" in our code to designate
9969     these wrapper types.
9970
9971     In some cases, the size allocated for each element is statically
9972     known.  In that case, the PAD type already has the correct size,
9973     and the array element should remain unfixed.
9974
9975     But there are cases when this size is not statically known.
9976     For instance, assuming that "Five" is an integer variable:
9977
9978         type Dynamic is array (1 .. Five) of Integer;
9979         type Wrapper (Has_Length : Boolean := False) is record
9980            Data : Dynamic;
9981            case Has_Length is
9982               when True => Length : Integer;
9983               when False => null;
9984            end case;
9985         end record;
9986         type Wrapper_Array is array (1 .. 2) of Wrapper;
9987
9988         Hello : Wrapper_Array := (others => (Has_Length => True,
9989                                              Data => (others => 17),
9990                                              Length => 1));
9991
9992
9993     The debugging info would describe variable Hello as being an
9994     array of a PAD type.  The size of that PAD type is not statically
9995     known, but can be determined using a parallel XVZ variable.
9996     In that case, a copy of the PAD type with the correct size should
9997     be used for the fixed array.
9998
9999     3. ``Fixing'' record type objects:
10000     ----------------------------------
10001
10002     Things are slightly different from arrays in the case of dynamic
10003     record types.  In this case, in order to compute the associated
10004     fixed type, we need to determine the size and offset of each of
10005     its components.  This, in turn, requires us to compute the fixed
10006     type of each of these components.
10007
10008     Consider for instance the example:
10009
10010         type Bounded_String (Max_Size : Natural) is record
10011            Str : String (1 .. Max_Size);
10012            Length : Natural;
10013         end record;
10014         My_String : Bounded_String (Max_Size => 10);
10015
10016     In that case, the position of field "Length" depends on the size
10017     of field Str, which itself depends on the value of the Max_Size
10018     discriminant.  In order to fix the type of variable My_String,
10019     we need to fix the type of field Str.  Therefore, fixing a variant
10020     record requires us to fix each of its components.
10021
10022     However, if a component does not have a dynamic size, the component
10023     should not be fixed.  In particular, fields that use a PAD type
10024     should not fixed.  Here is an example where this might happen
10025     (assuming type Rec above):
10026
10027        type Container (Big : Boolean) is record
10028           First : Rec;
10029           After : Integer;
10030           case Big is
10031              when True => Another : Integer;
10032              when False => null;
10033           end case;
10034        end record;
10035        My_Container : Container := (Big => False,
10036                                     First => (Empty => True),
10037                                     After => 42);
10038
10039     In that example, the compiler creates a PAD type for component First,
10040     whose size is constant, and then positions the component After just
10041     right after it.  The offset of component After is therefore constant
10042     in this case.
10043
10044     The debugger computes the position of each field based on an algorithm
10045     that uses, among other things, the actual position and size of the field
10046     preceding it.  Let's now imagine that the user is trying to print
10047     the value of My_Container.  If the type fixing was recursive, we would
10048     end up computing the offset of field After based on the size of the
10049     fixed version of field First.  And since in our example First has
10050     only one actual field, the size of the fixed type is actually smaller
10051     than the amount of space allocated to that field, and thus we would
10052     compute the wrong offset of field After.
10053
10054     To make things more complicated, we need to watch out for dynamic
10055     components of variant records (identified by the ___XVL suffix in
10056     the component name).  Even if the target type is a PAD type, the size
10057     of that type might not be statically known.  So the PAD type needs
10058     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
10059     we might end up with the wrong size for our component.  This can be
10060     observed with the following type declarations:
10061
10062         type Octal is new Integer range 0 .. 7;
10063         type Octal_Array is array (Positive range <>) of Octal;
10064         pragma Pack (Octal_Array);
10065
10066         type Octal_Buffer (Size : Positive) is record
10067            Buffer : Octal_Array (1 .. Size);
10068            Length : Integer;
10069         end record;
10070
10071     In that case, Buffer is a PAD type whose size is unset and needs
10072     to be computed by fixing the unwrapped type.
10073
10074     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10075     ----------------------------------------------------------
10076
10077     Lastly, when should the sub-elements of an entity that remained unfixed
10078     thus far, be actually fixed?
10079
10080     The answer is: Only when referencing that element.  For instance
10081     when selecting one component of a record, this specific component
10082     should be fixed at that point in time.  Or when printing the value
10083     of a record, each component should be fixed before its value gets
10084     printed.  Similarly for arrays, the element of the array should be
10085     fixed when printing each element of the array, or when extracting
10086     one element out of that array.  On the other hand, fixing should
10087     not be performed on the elements when taking a slice of an array!
10088
10089     Note that one of the side effects of miscomputing the offset and
10090     size of each field is that we end up also miscomputing the size
10091     of the containing type.  This can have adverse results when computing
10092     the value of an entity.  GDB fetches the value of an entity based
10093     on the size of its type, and thus a wrong size causes GDB to fetch
10094     the wrong amount of memory.  In the case where the computed size is
10095     too small, GDB fetches too little data to print the value of our
10096     entity.  Results in this case are unpredictable, as we usually read
10097     past the buffer containing the data =:-o.  */
10098
10099 /* A helper function for TERNOP_IN_RANGE.  */
10100
10101 static value *
10102 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
10103                       enum noside noside,
10104                       value *arg1, value *arg2, value *arg3)
10105 {
10106   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10107   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10108   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10109   return
10110     value_from_longest (type,
10111                         (value_less (arg1, arg3)
10112                          || value_equal (arg1, arg3))
10113                         && (value_less (arg2, arg1)
10114                             || value_equal (arg2, arg1)));
10115 }
10116
10117 /* A helper function for UNOP_NEG.  */
10118
10119 value *
10120 ada_unop_neg (struct type *expect_type,
10121               struct expression *exp,
10122               enum noside noside, enum exp_opcode op,
10123               struct value *arg1)
10124 {
10125   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10126   return value_neg (arg1);
10127 }
10128
10129 /* A helper function for UNOP_IN_RANGE.  */
10130
10131 value *
10132 ada_unop_in_range (struct type *expect_type,
10133                    struct expression *exp,
10134                    enum noside noside, enum exp_opcode op,
10135                    struct value *arg1, struct type *type)
10136 {
10137   struct value *arg2, *arg3;
10138   switch (type->code ())
10139     {
10140     default:
10141       lim_warning (_("Membership test incompletely implemented; "
10142                      "always returns true"));
10143       type = language_bool_type (exp->language_defn, exp->gdbarch);
10144       return value_from_longest (type, (LONGEST) 1);
10145
10146     case TYPE_CODE_RANGE:
10147       arg2 = value_from_longest (type,
10148                                  type->bounds ()->low.const_val ());
10149       arg3 = value_from_longest (type,
10150                                  type->bounds ()->high.const_val ());
10151       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10152       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10153       type = language_bool_type (exp->language_defn, exp->gdbarch);
10154       return
10155         value_from_longest (type,
10156                             (value_less (arg1, arg3)
10157                              || value_equal (arg1, arg3))
10158                             && (value_less (arg2, arg1)
10159                                 || value_equal (arg2, arg1)));
10160     }
10161 }
10162
10163 /* A helper function for OP_ATR_TAG.  */
10164
10165 value *
10166 ada_atr_tag (struct type *expect_type,
10167              struct expression *exp,
10168              enum noside noside, enum exp_opcode op,
10169              struct value *arg1)
10170 {
10171   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10172     return value_zero (ada_tag_type (arg1), not_lval);
10173
10174   return ada_value_tag (arg1);
10175 }
10176
10177 /* A helper function for OP_ATR_SIZE.  */
10178
10179 value *
10180 ada_atr_size (struct type *expect_type,
10181               struct expression *exp,
10182               enum noside noside, enum exp_opcode op,
10183               struct value *arg1)
10184 {
10185   struct type *type = value_type (arg1);
10186
10187   /* If the argument is a reference, then dereference its type, since
10188      the user is really asking for the size of the actual object,
10189      not the size of the pointer.  */
10190   if (type->code () == TYPE_CODE_REF)
10191     type = type->target_type ();
10192
10193   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10194     return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
10195   else
10196     return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
10197                                TARGET_CHAR_BIT * type->length ());
10198 }
10199
10200 /* A helper function for UNOP_ABS.  */
10201
10202 value *
10203 ada_abs (struct type *expect_type,
10204          struct expression *exp,
10205          enum noside noside, enum exp_opcode op,
10206          struct value *arg1)
10207 {
10208   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10209   if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
10210     return value_neg (arg1);
10211   else
10212     return arg1;
10213 }
10214
10215 /* A helper function for BINOP_MUL.  */
10216
10217 value *
10218 ada_mult_binop (struct type *expect_type,
10219                 struct expression *exp,
10220                 enum noside noside, enum exp_opcode op,
10221                 struct value *arg1, struct value *arg2)
10222 {
10223   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10224     {
10225       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10226       return value_zero (value_type (arg1), not_lval);
10227     }
10228   else
10229     {
10230       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10231       return ada_value_binop (arg1, arg2, op);
10232     }
10233 }
10234
10235 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL.  */
10236
10237 value *
10238 ada_equal_binop (struct type *expect_type,
10239                  struct expression *exp,
10240                  enum noside noside, enum exp_opcode op,
10241                  struct value *arg1, struct value *arg2)
10242 {
10243   int tem;
10244   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10245     tem = 0;
10246   else
10247     {
10248       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10249       tem = ada_value_equal (arg1, arg2);
10250     }
10251   if (op == BINOP_NOTEQUAL)
10252     tem = !tem;
10253   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10254   return value_from_longest (type, (LONGEST) tem);
10255 }
10256
10257 /* A helper function for TERNOP_SLICE.  */
10258
10259 value *
10260 ada_ternop_slice (struct expression *exp,
10261                   enum noside noside,
10262                   struct value *array, struct value *low_bound_val,
10263                   struct value *high_bound_val)
10264 {
10265   LONGEST low_bound;
10266   LONGEST high_bound;
10267
10268   low_bound_val = coerce_ref (low_bound_val);
10269   high_bound_val = coerce_ref (high_bound_val);
10270   low_bound = value_as_long (low_bound_val);
10271   high_bound = value_as_long (high_bound_val);
10272
10273   /* If this is a reference to an aligner type, then remove all
10274      the aligners.  */
10275   if (value_type (array)->code () == TYPE_CODE_REF
10276       && ada_is_aligner_type (value_type (array)->target_type ()))
10277     value_type (array)->set_target_type
10278       (ada_aligned_type (value_type (array)->target_type ()));
10279
10280   if (ada_is_any_packed_array_type (value_type (array)))
10281     error (_("cannot slice a packed array"));
10282
10283   /* If this is a reference to an array or an array lvalue,
10284      convert to a pointer.  */
10285   if (value_type (array)->code () == TYPE_CODE_REF
10286       || (value_type (array)->code () == TYPE_CODE_ARRAY
10287           && VALUE_LVAL (array) == lval_memory))
10288     array = value_addr (array);
10289
10290   if (noside == EVAL_AVOID_SIDE_EFFECTS
10291       && ada_is_array_descriptor_type (ada_check_typedef
10292                                        (value_type (array))))
10293     return empty_array (ada_type_of_array (array, 0), low_bound,
10294                         high_bound);
10295
10296   array = ada_coerce_to_simple_array_ptr (array);
10297
10298   /* If we have more than one level of pointer indirection,
10299      dereference the value until we get only one level.  */
10300   while (value_type (array)->code () == TYPE_CODE_PTR
10301          && (value_type (array)->target_type ()->code ()
10302              == TYPE_CODE_PTR))
10303     array = value_ind (array);
10304
10305   /* Make sure we really do have an array type before going further,
10306      to avoid a SEGV when trying to get the index type or the target
10307      type later down the road if the debug info generated by
10308      the compiler is incorrect or incomplete.  */
10309   if (!ada_is_simple_array_type (value_type (array)))
10310     error (_("cannot take slice of non-array"));
10311
10312   if (ada_check_typedef (value_type (array))->code ()
10313       == TYPE_CODE_PTR)
10314     {
10315       struct type *type0 = ada_check_typedef (value_type (array));
10316
10317       if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10318         return empty_array (type0->target_type (), low_bound, high_bound);
10319       else
10320         {
10321           struct type *arr_type0 =
10322             to_fixed_array_type (type0->target_type (), NULL, 1);
10323
10324           return ada_value_slice_from_ptr (array, arr_type0,
10325                                            longest_to_int (low_bound),
10326                                            longest_to_int (high_bound));
10327         }
10328     }
10329   else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10330     return array;
10331   else if (high_bound < low_bound)
10332     return empty_array (value_type (array), low_bound, high_bound);
10333   else
10334     return ada_value_slice (array, longest_to_int (low_bound),
10335                             longest_to_int (high_bound));
10336 }
10337
10338 /* A helper function for BINOP_IN_BOUNDS.  */
10339
10340 value *
10341 ada_binop_in_bounds (struct expression *exp, enum noside noside,
10342                      struct value *arg1, struct value *arg2, int n)
10343 {
10344   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10345     {
10346       struct type *type = language_bool_type (exp->language_defn,
10347                                               exp->gdbarch);
10348       return value_zero (type, not_lval);
10349     }
10350
10351   struct type *type = ada_index_type (value_type (arg2), n, "range");
10352   if (!type)
10353     type = value_type (arg1);
10354
10355   value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
10356   arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
10357
10358   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10359   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10360   type = language_bool_type (exp->language_defn, exp->gdbarch);
10361   return value_from_longest (type,
10362                              (value_less (arg1, arg3)
10363                               || value_equal (arg1, arg3))
10364                              && (value_less (arg2, arg1)
10365                                  || value_equal (arg2, arg1)));
10366 }
10367
10368 /* A helper function for some attribute operations.  */
10369
10370 static value *
10371 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
10372               struct value *arg1, struct type *type_arg, int tem)
10373 {
10374   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10375     {
10376       if (type_arg == NULL)
10377         type_arg = value_type (arg1);
10378
10379       if (ada_is_constrained_packed_array_type (type_arg))
10380         type_arg = decode_constrained_packed_array_type (type_arg);
10381
10382       if (!discrete_type_p (type_arg))
10383         {
10384           switch (op)
10385             {
10386             default:          /* Should never happen.  */
10387               error (_("unexpected attribute encountered"));
10388             case OP_ATR_FIRST:
10389             case OP_ATR_LAST:
10390               type_arg = ada_index_type (type_arg, tem,
10391                                          ada_attribute_name (op));
10392               break;
10393             case OP_ATR_LENGTH:
10394               type_arg = builtin_type (exp->gdbarch)->builtin_int;
10395               break;
10396             }
10397         }
10398
10399       return value_zero (type_arg, not_lval);
10400     }
10401   else if (type_arg == NULL)
10402     {
10403       arg1 = ada_coerce_ref (arg1);
10404
10405       if (ada_is_constrained_packed_array_type (value_type (arg1)))
10406         arg1 = ada_coerce_to_simple_array (arg1);
10407
10408       struct type *type;
10409       if (op == OP_ATR_LENGTH)
10410         type = builtin_type (exp->gdbarch)->builtin_int;
10411       else
10412         {
10413           type = ada_index_type (value_type (arg1), tem,
10414                                  ada_attribute_name (op));
10415           if (type == NULL)
10416             type = builtin_type (exp->gdbarch)->builtin_int;
10417         }
10418
10419       switch (op)
10420         {
10421         default:          /* Should never happen.  */
10422           error (_("unexpected attribute encountered"));
10423         case OP_ATR_FIRST:
10424           return value_from_longest
10425             (type, ada_array_bound (arg1, tem, 0));
10426         case OP_ATR_LAST:
10427           return value_from_longest
10428             (type, ada_array_bound (arg1, tem, 1));
10429         case OP_ATR_LENGTH:
10430           return value_from_longest
10431             (type, ada_array_length (arg1, tem));
10432         }
10433     }
10434   else if (discrete_type_p (type_arg))
10435     {
10436       struct type *range_type;
10437       const char *name = ada_type_name (type_arg);
10438
10439       range_type = NULL;
10440       if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10441         range_type = to_fixed_range_type (type_arg, NULL);
10442       if (range_type == NULL)
10443         range_type = type_arg;
10444       switch (op)
10445         {
10446         default:
10447           error (_("unexpected attribute encountered"));
10448         case OP_ATR_FIRST:
10449           return value_from_longest 
10450             (range_type, ada_discrete_type_low_bound (range_type));
10451         case OP_ATR_LAST:
10452           return value_from_longest
10453             (range_type, ada_discrete_type_high_bound (range_type));
10454         case OP_ATR_LENGTH:
10455           error (_("the 'length attribute applies only to array types"));
10456         }
10457     }
10458   else if (type_arg->code () == TYPE_CODE_FLT)
10459     error (_("unimplemented type attribute"));
10460   else
10461     {
10462       LONGEST low, high;
10463
10464       if (ada_is_constrained_packed_array_type (type_arg))
10465         type_arg = decode_constrained_packed_array_type (type_arg);
10466
10467       struct type *type;
10468       if (op == OP_ATR_LENGTH)
10469         type = builtin_type (exp->gdbarch)->builtin_int;
10470       else
10471         {
10472           type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10473           if (type == NULL)
10474             type = builtin_type (exp->gdbarch)->builtin_int;
10475         }
10476
10477       switch (op)
10478         {
10479         default:
10480           error (_("unexpected attribute encountered"));
10481         case OP_ATR_FIRST:
10482           low = ada_array_bound_from_type (type_arg, tem, 0);
10483           return value_from_longest (type, low);
10484         case OP_ATR_LAST:
10485           high = ada_array_bound_from_type (type_arg, tem, 1);
10486           return value_from_longest (type, high);
10487         case OP_ATR_LENGTH:
10488           low = ada_array_bound_from_type (type_arg, tem, 0);
10489           high = ada_array_bound_from_type (type_arg, tem, 1);
10490           return value_from_longest (type, high - low + 1);
10491         }
10492     }
10493 }
10494
10495 /* A helper function for OP_ATR_MIN and OP_ATR_MAX.  */
10496
10497 struct value *
10498 ada_binop_minmax (struct type *expect_type,
10499                   struct expression *exp,
10500                   enum noside noside, enum exp_opcode op,
10501                   struct value *arg1, struct value *arg2)
10502 {
10503   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10504     return value_zero (value_type (arg1), not_lval);
10505   else
10506     {
10507       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10508       return value_binop (arg1, arg2, op);
10509     }
10510 }
10511
10512 /* A helper function for BINOP_EXP.  */
10513
10514 struct value *
10515 ada_binop_exp (struct type *expect_type,
10516                struct expression *exp,
10517                enum noside noside, enum exp_opcode op,
10518                struct value *arg1, struct value *arg2)
10519 {
10520   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10521     return value_zero (value_type (arg1), not_lval);
10522   else
10523     {
10524       /* For integer exponentiation operations,
10525          only promote the first argument.  */
10526       if (is_integral_type (value_type (arg2)))
10527         unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10528       else
10529         binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10530
10531       return value_binop (arg1, arg2, op);
10532     }
10533 }
10534
10535 namespace expr
10536 {
10537
10538 /* See ada-exp.h.  */
10539
10540 operation_up
10541 ada_resolvable::replace (operation_up &&owner,
10542                          struct expression *exp,
10543                          bool deprocedure_p,
10544                          bool parse_completion,
10545                          innermost_block_tracker *tracker,
10546                          struct type *context_type)
10547 {
10548   if (resolve (exp, deprocedure_p, parse_completion, tracker, context_type))
10549     return (make_operation<ada_funcall_operation>
10550             (std::move (owner),
10551              std::vector<operation_up> ()));
10552   return std::move (owner);
10553 }
10554
10555 /* Convert the character literal whose value would be VAL to the
10556    appropriate value of type TYPE, if there is a translation.
10557    Otherwise return VAL.  Hence, in an enumeration type ('A', 'B'),
10558    the literal 'A' (VAL == 65), returns 0.  */
10559
10560 static LONGEST
10561 convert_char_literal (struct type *type, LONGEST val)
10562 {
10563   char name[12];
10564   int f;
10565
10566   if (type == NULL)
10567     return val;
10568   type = check_typedef (type);
10569   if (type->code () != TYPE_CODE_ENUM)
10570     return val;
10571
10572   if ((val >= 'a' && val <= 'z') || (val >= '0' && val <= '9'))
10573     xsnprintf (name, sizeof (name), "Q%c", (int) val);
10574   else if (val >= 0 && val < 256)
10575     xsnprintf (name, sizeof (name), "QU%02x", (unsigned) val);
10576   else if (val >= 0 && val < 0x10000)
10577     xsnprintf (name, sizeof (name), "QW%04x", (unsigned) val);
10578   else
10579     xsnprintf (name, sizeof (name), "QWW%08lx", (unsigned long) val);
10580   size_t len = strlen (name);
10581   for (f = 0; f < type->num_fields (); f += 1)
10582     {
10583       /* Check the suffix because an enum constant in a package will
10584          have a name like "pkg__QUxx".  This is safe enough because we
10585          already have the correct type, and because mangling means
10586          there can't be clashes.  */
10587       const char *ename = type->field (f).name ();
10588       size_t elen = strlen (ename);
10589
10590       if (elen >= len && strcmp (name, ename + elen - len) == 0)
10591         return type->field (f).loc_enumval ();
10592     }
10593   return val;
10594 }
10595
10596 value *
10597 ada_char_operation::evaluate (struct type *expect_type,
10598                               struct expression *exp,
10599                               enum noside noside)
10600 {
10601   value *result = long_const_operation::evaluate (expect_type, exp, noside);
10602   if (expect_type != nullptr)
10603     result = ada_value_cast (expect_type, result);
10604   return result;
10605 }
10606
10607 /* See ada-exp.h.  */
10608
10609 operation_up
10610 ada_char_operation::replace (operation_up &&owner,
10611                              struct expression *exp,
10612                              bool deprocedure_p,
10613                              bool parse_completion,
10614                              innermost_block_tracker *tracker,
10615                              struct type *context_type)
10616 {
10617   operation_up result = std::move (owner);
10618
10619   if (context_type != nullptr && context_type->code () == TYPE_CODE_ENUM)
10620     {
10621       gdb_assert (result.get () == this);
10622       std::get<0> (m_storage) = context_type;
10623       std::get<1> (m_storage)
10624         = convert_char_literal (context_type, std::get<1> (m_storage));
10625     }
10626
10627   return result;
10628 }
10629
10630 value *
10631 ada_wrapped_operation::evaluate (struct type *expect_type,
10632                                  struct expression *exp,
10633                                  enum noside noside)
10634 {
10635   value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10636   if (noside == EVAL_NORMAL)
10637     result = unwrap_value (result);
10638
10639   /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10640      then we need to perform the conversion manually, because
10641      evaluate_subexp_standard doesn't do it.  This conversion is
10642      necessary in Ada because the different kinds of float/fixed
10643      types in Ada have different representations.
10644
10645      Similarly, we need to perform the conversion from OP_LONG
10646      ourselves.  */
10647   if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10648     result = ada_value_cast (expect_type, result);
10649
10650   return result;
10651 }
10652
10653 value *
10654 ada_string_operation::evaluate (struct type *expect_type,
10655                                 struct expression *exp,
10656                                 enum noside noside)
10657 {
10658   struct type *char_type;
10659   if (expect_type != nullptr && ada_is_string_type (expect_type))
10660     char_type = ada_array_element_type (expect_type, 1);
10661   else
10662     char_type = language_string_char_type (exp->language_defn, exp->gdbarch);
10663
10664   const std::string &str = std::get<0> (m_storage);
10665   const char *encoding;
10666   switch (char_type->length ())
10667     {
10668     case 1:
10669       {
10670         /* Simply copy over the data -- this isn't perhaps strictly
10671            correct according to the encodings, but it is gdb's
10672            historical behavior.  */
10673         struct type *stringtype
10674           = lookup_array_range_type (char_type, 1, str.length ());
10675         struct value *val = allocate_value (stringtype);
10676         memcpy (value_contents_raw (val).data (), str.c_str (),
10677                 str.length ());
10678         return val;
10679       }
10680
10681     case 2:
10682       if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10683         encoding = "UTF-16BE";
10684       else
10685         encoding = "UTF-16LE";
10686       break;
10687
10688     case 4:
10689       if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10690         encoding = "UTF-32BE";
10691       else
10692         encoding = "UTF-32LE";
10693       break;
10694
10695     default:
10696       error (_("unexpected character type size %s"),
10697              pulongest (char_type->length ()));
10698     }
10699
10700   auto_obstack converted;
10701   convert_between_encodings (host_charset (), encoding,
10702                              (const gdb_byte *) str.c_str (),
10703                              str.length (), 1,
10704                              &converted, translit_none);
10705
10706   struct type *stringtype
10707     = lookup_array_range_type (char_type, 1,
10708                                obstack_object_size (&converted)
10709                                / char_type->length ());
10710   struct value *val = allocate_value (stringtype);
10711   memcpy (value_contents_raw (val).data (),
10712           obstack_base (&converted),
10713           obstack_object_size (&converted));
10714   return val;
10715 }
10716
10717 value *
10718 ada_concat_operation::evaluate (struct type *expect_type,
10719                                 struct expression *exp,
10720                                 enum noside noside)
10721 {
10722   /* If one side is a literal, evaluate the other side first so that
10723      the expected type can be set properly.  */
10724   const operation_up &lhs_expr = std::get<0> (m_storage);
10725   const operation_up &rhs_expr = std::get<1> (m_storage);
10726
10727   value *lhs, *rhs;
10728   if (dynamic_cast<ada_string_operation *> (lhs_expr.get ()) != nullptr)
10729     {
10730       rhs = rhs_expr->evaluate (nullptr, exp, noside);
10731       lhs = lhs_expr->evaluate (value_type (rhs), exp, noside);
10732     }
10733   else if (dynamic_cast<ada_char_operation *> (lhs_expr.get ()) != nullptr)
10734     {
10735       rhs = rhs_expr->evaluate (nullptr, exp, noside);
10736       struct type *rhs_type = check_typedef (value_type (rhs));
10737       struct type *elt_type = nullptr;
10738       if (rhs_type->code () == TYPE_CODE_ARRAY)
10739         elt_type = rhs_type->target_type ();
10740       lhs = lhs_expr->evaluate (elt_type, exp, noside);
10741     }
10742   else if (dynamic_cast<ada_string_operation *> (rhs_expr.get ()) != nullptr)
10743     {
10744       lhs = lhs_expr->evaluate (nullptr, exp, noside);
10745       rhs = rhs_expr->evaluate (value_type (lhs), exp, noside);
10746     }
10747   else if (dynamic_cast<ada_char_operation *> (rhs_expr.get ()) != nullptr)
10748     {
10749       lhs = lhs_expr->evaluate (nullptr, exp, noside);
10750       struct type *lhs_type = check_typedef (value_type (lhs));
10751       struct type *elt_type = nullptr;
10752       if (lhs_type->code () == TYPE_CODE_ARRAY)
10753         elt_type = lhs_type->target_type ();
10754       rhs = rhs_expr->evaluate (elt_type, exp, noside);
10755     }
10756   else
10757     return concat_operation::evaluate (expect_type, exp, noside);
10758
10759   return value_concat (lhs, rhs);
10760 }
10761
10762 value *
10763 ada_qual_operation::evaluate (struct type *expect_type,
10764                               struct expression *exp,
10765                               enum noside noside)
10766 {
10767   struct type *type = std::get<1> (m_storage);
10768   return std::get<0> (m_storage)->evaluate (type, exp, noside);
10769 }
10770
10771 value *
10772 ada_ternop_range_operation::evaluate (struct type *expect_type,
10773                                       struct expression *exp,
10774                                       enum noside noside)
10775 {
10776   value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10777   value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10778   value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10779   return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10780 }
10781
10782 value *
10783 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10784                                       struct expression *exp,
10785                                       enum noside noside)
10786 {
10787   value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10788   value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10789
10790   auto do_op = [=] (LONGEST x, LONGEST y)
10791     {
10792       if (std::get<0> (m_storage) == BINOP_ADD)
10793         return x + y;
10794       return x - y;
10795     };
10796
10797   if (value_type (arg1)->code () == TYPE_CODE_PTR)
10798     return (value_from_longest
10799             (value_type (arg1),
10800              do_op (value_as_long (arg1), value_as_long (arg2))));
10801   if (value_type (arg2)->code () == TYPE_CODE_PTR)
10802     return (value_from_longest
10803             (value_type (arg2),
10804              do_op (value_as_long (arg1), value_as_long (arg2))));
10805   /* Preserve the original type for use by the range case below.
10806      We cannot cast the result to a reference type, so if ARG1 is
10807      a reference type, find its underlying type.  */
10808   struct type *type = value_type (arg1);
10809   while (type->code () == TYPE_CODE_REF)
10810     type = type->target_type ();
10811   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10812   arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10813   /* We need to special-case the result with a range.
10814      This is done for the benefit of "ptype".  gdb's Ada support
10815      historically used the LHS to set the result type here, so
10816      preserve this behavior.  */
10817   if (type->code () == TYPE_CODE_RANGE)
10818     arg1 = value_cast (type, arg1);
10819   return arg1;
10820 }
10821
10822 value *
10823 ada_unop_atr_operation::evaluate (struct type *expect_type,
10824                                   struct expression *exp,
10825                                   enum noside noside)
10826 {
10827   struct type *type_arg = nullptr;
10828   value *val = nullptr;
10829
10830   if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10831     {
10832       value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10833                                                       EVAL_AVOID_SIDE_EFFECTS);
10834       type_arg = value_type (tem);
10835     }
10836   else
10837     val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10838
10839   return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10840                        val, type_arg, std::get<2> (m_storage));
10841 }
10842
10843 value *
10844 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10845                                                  struct expression *exp,
10846                                                  enum noside noside)
10847 {
10848   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10849     return value_zero (expect_type, not_lval);
10850
10851   const bound_minimal_symbol &b = std::get<0> (m_storage);
10852   value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10853
10854   val = ada_value_cast (expect_type, val);
10855
10856   /* Follow the Ada language semantics that do not allow taking
10857      an address of the result of a cast (view conversion in Ada).  */
10858   if (VALUE_LVAL (val) == lval_memory)
10859     {
10860       if (value_lazy (val))
10861         value_fetch_lazy (val);
10862       VALUE_LVAL (val) = not_lval;
10863     }
10864   return val;
10865 }
10866
10867 value *
10868 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10869                                             struct expression *exp,
10870                                             enum noside noside)
10871 {
10872   value *val = evaluate_var_value (noside,
10873                                    std::get<0> (m_storage).block,
10874                                    std::get<0> (m_storage).symbol);
10875
10876   val = ada_value_cast (expect_type, val);
10877
10878   /* Follow the Ada language semantics that do not allow taking
10879      an address of the result of a cast (view conversion in Ada).  */
10880   if (VALUE_LVAL (val) == lval_memory)
10881     {
10882       if (value_lazy (val))
10883         value_fetch_lazy (val);
10884       VALUE_LVAL (val) = not_lval;
10885     }
10886   return val;
10887 }
10888
10889 value *
10890 ada_var_value_operation::evaluate (struct type *expect_type,
10891                                    struct expression *exp,
10892                                    enum noside noside)
10893 {
10894   symbol *sym = std::get<0> (m_storage).symbol;
10895
10896   if (sym->domain () == UNDEF_DOMAIN)
10897     /* Only encountered when an unresolved symbol occurs in a
10898        context other than a function call, in which case, it is
10899        invalid.  */
10900     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10901            sym->print_name ());
10902
10903   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10904     {
10905       struct type *type = static_unwrap_type (sym->type ());
10906       /* Check to see if this is a tagged type.  We also need to handle
10907          the case where the type is a reference to a tagged type, but
10908          we have to be careful to exclude pointers to tagged types.
10909          The latter should be shown as usual (as a pointer), whereas
10910          a reference should mostly be transparent to the user.  */
10911       if (ada_is_tagged_type (type, 0)
10912           || (type->code () == TYPE_CODE_REF
10913               && ada_is_tagged_type (type->target_type (), 0)))
10914         {
10915           /* Tagged types are a little special in the fact that the real
10916              type is dynamic and can only be determined by inspecting the
10917              object's tag.  This means that we need to get the object's
10918              value first (EVAL_NORMAL) and then extract the actual object
10919              type from its tag.
10920
10921              Note that we cannot skip the final step where we extract
10922              the object type from its tag, because the EVAL_NORMAL phase
10923              results in dynamic components being resolved into fixed ones.
10924              This can cause problems when trying to print the type
10925              description of tagged types whose parent has a dynamic size:
10926              We use the type name of the "_parent" component in order
10927              to print the name of the ancestor type in the type description.
10928              If that component had a dynamic size, the resolution into
10929              a fixed type would result in the loss of that type name,
10930              thus preventing us from printing the name of the ancestor
10931              type in the type description.  */
10932           value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10933
10934           if (type->code () != TYPE_CODE_REF)
10935             {
10936               struct type *actual_type;
10937
10938               actual_type = type_from_tag (ada_value_tag (arg1));
10939               if (actual_type == NULL)
10940                 /* If, for some reason, we were unable to determine
10941                    the actual type from the tag, then use the static
10942                    approximation that we just computed as a fallback.
10943                    This can happen if the debugging information is
10944                    incomplete, for instance.  */
10945                 actual_type = type;
10946               return value_zero (actual_type, not_lval);
10947             }
10948           else
10949             {
10950               /* In the case of a ref, ada_coerce_ref takes care
10951                  of determining the actual type.  But the evaluation
10952                  should return a ref as it should be valid to ask
10953                  for its address; so rebuild a ref after coerce.  */
10954               arg1 = ada_coerce_ref (arg1);
10955               return value_ref (arg1, TYPE_CODE_REF);
10956             }
10957         }
10958
10959       /* Records and unions for which GNAT encodings have been
10960          generated need to be statically fixed as well.
10961          Otherwise, non-static fixing produces a type where
10962          all dynamic properties are removed, which prevents "ptype"
10963          from being able to completely describe the type.
10964          For instance, a case statement in a variant record would be
10965          replaced by the relevant components based on the actual
10966          value of the discriminants.  */
10967       if ((type->code () == TYPE_CODE_STRUCT
10968            && dynamic_template_type (type) != NULL)
10969           || (type->code () == TYPE_CODE_UNION
10970               && ada_find_parallel_type (type, "___XVU") != NULL))
10971         return value_zero (to_static_fixed_type (type), not_lval);
10972     }
10973
10974   value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10975   return ada_to_fixed_value (arg1);
10976 }
10977
10978 bool
10979 ada_var_value_operation::resolve (struct expression *exp,
10980                                   bool deprocedure_p,
10981                                   bool parse_completion,
10982                                   innermost_block_tracker *tracker,
10983                                   struct type *context_type)
10984 {
10985   symbol *sym = std::get<0> (m_storage).symbol;
10986   if (sym->domain () == UNDEF_DOMAIN)
10987     {
10988       block_symbol resolved
10989         = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10990                                 context_type, parse_completion,
10991                                 deprocedure_p, tracker);
10992       std::get<0> (m_storage) = resolved;
10993     }
10994
10995   if (deprocedure_p
10996       && (std::get<0> (m_storage).symbol->type ()->code ()
10997           == TYPE_CODE_FUNC))
10998     return true;
10999
11000   return false;
11001 }
11002
11003 value *
11004 ada_atr_val_operation::evaluate (struct type *expect_type,
11005                                  struct expression *exp,
11006                                  enum noside noside)
11007 {
11008   value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
11009   return ada_val_atr (noside, std::get<0> (m_storage), arg);
11010 }
11011
11012 value *
11013 ada_unop_ind_operation::evaluate (struct type *expect_type,
11014                                   struct expression *exp,
11015                                   enum noside noside)
11016 {
11017   value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
11018
11019   struct type *type = ada_check_typedef (value_type (arg1));
11020   if (noside == EVAL_AVOID_SIDE_EFFECTS)
11021     {
11022       if (ada_is_array_descriptor_type (type))
11023         /* GDB allows dereferencing GNAT array descriptors.  */
11024         {
11025           struct type *arrType = ada_type_of_array (arg1, 0);
11026
11027           if (arrType == NULL)
11028             error (_("Attempt to dereference null array pointer."));
11029           return value_at_lazy (arrType, 0);
11030         }
11031       else if (type->code () == TYPE_CODE_PTR
11032                || type->code () == TYPE_CODE_REF
11033                /* In C you can dereference an array to get the 1st elt.  */
11034                || type->code () == TYPE_CODE_ARRAY)
11035         {
11036           /* As mentioned in the OP_VAR_VALUE case, tagged types can
11037              only be determined by inspecting the object's tag.
11038              This means that we need to evaluate completely the
11039              expression in order to get its type.  */
11040
11041           if ((type->code () == TYPE_CODE_REF
11042                || type->code () == TYPE_CODE_PTR)
11043               && ada_is_tagged_type (type->target_type (), 0))
11044             {
11045               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11046                                                         EVAL_NORMAL);
11047               type = value_type (ada_value_ind (arg1));
11048             }
11049           else
11050             {
11051               type = to_static_fixed_type
11052                 (ada_aligned_type
11053                  (ada_check_typedef (type->target_type ())));
11054             }
11055           return value_zero (type, lval_memory);
11056         }
11057       else if (type->code () == TYPE_CODE_INT)
11058         {
11059           /* GDB allows dereferencing an int.  */
11060           if (expect_type == NULL)
11061             return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11062                                lval_memory);
11063           else
11064             {
11065               expect_type =
11066                 to_static_fixed_type (ada_aligned_type (expect_type));
11067               return value_zero (expect_type, lval_memory);
11068             }
11069         }
11070       else
11071         error (_("Attempt to take contents of a non-pointer value."));
11072     }
11073   arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for??  */
11074   type = ada_check_typedef (value_type (arg1));
11075
11076   if (type->code () == TYPE_CODE_INT)
11077     /* GDB allows dereferencing an int.  If we were given
11078        the expect_type, then use that as the target type.
11079        Otherwise, assume that the target type is an int.  */
11080     {
11081       if (expect_type != NULL)
11082         return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11083                                           arg1));
11084       else
11085         return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11086                               (CORE_ADDR) value_as_address (arg1));
11087     }
11088
11089   if (ada_is_array_descriptor_type (type))
11090     /* GDB allows dereferencing GNAT array descriptors.  */
11091     return ada_coerce_to_simple_array (arg1);
11092   else
11093     return ada_value_ind (arg1);
11094 }
11095
11096 value *
11097 ada_structop_operation::evaluate (struct type *expect_type,
11098                                   struct expression *exp,
11099                                   enum noside noside)
11100 {
11101   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
11102   const char *str = std::get<1> (m_storage).c_str ();
11103   if (noside == EVAL_AVOID_SIDE_EFFECTS)
11104     {
11105       struct type *type;
11106       struct type *type1 = value_type (arg1);
11107
11108       if (ada_is_tagged_type (type1, 1))
11109         {
11110           type = ada_lookup_struct_elt_type (type1, str, 1, 1);
11111
11112           /* If the field is not found, check if it exists in the
11113              extension of this object's type. This means that we
11114              need to evaluate completely the expression.  */
11115
11116           if (type == NULL)
11117             {
11118               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11119                                                         EVAL_NORMAL);
11120               arg1 = ada_value_struct_elt (arg1, str, 0);
11121               arg1 = unwrap_value (arg1);
11122               type = value_type (ada_to_fixed_value (arg1));
11123             }
11124         }
11125       else
11126         type = ada_lookup_struct_elt_type (type1, str, 1, 0);
11127
11128       return value_zero (ada_aligned_type (type), lval_memory);
11129     }
11130   else
11131     {
11132       arg1 = ada_value_struct_elt (arg1, str, 0);
11133       arg1 = unwrap_value (arg1);
11134       return ada_to_fixed_value (arg1);
11135     }
11136 }
11137
11138 value *
11139 ada_funcall_operation::evaluate (struct type *expect_type,
11140                                  struct expression *exp,
11141                                  enum noside noside)
11142 {
11143   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11144   int nargs = args_up.size ();
11145   std::vector<value *> argvec (nargs);
11146   operation_up &callee_op = std::get<0> (m_storage);
11147
11148   ada_var_value_operation *avv
11149     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11150   if (avv != nullptr
11151       && avv->get_symbol ()->domain () == UNDEF_DOMAIN)
11152     error (_("Unexpected unresolved symbol, %s, during evaluation"),
11153            avv->get_symbol ()->print_name ());
11154
11155   value *callee = callee_op->evaluate (nullptr, exp, noside);
11156   for (int i = 0; i < args_up.size (); ++i)
11157     argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
11158
11159   if (ada_is_constrained_packed_array_type
11160       (desc_base_type (value_type (callee))))
11161     callee = ada_coerce_to_simple_array (callee);
11162   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11163            && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
11164     /* This is a packed array that has already been fixed, and
11165        therefore already coerced to a simple array.  Nothing further
11166        to do.  */
11167     ;
11168   else if (value_type (callee)->code () == TYPE_CODE_REF)
11169     {
11170       /* Make sure we dereference references so that all the code below
11171          feels like it's really handling the referenced value.  Wrapping
11172          types (for alignment) may be there, so make sure we strip them as
11173          well.  */
11174       callee = ada_to_fixed_value (coerce_ref (callee));
11175     }
11176   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11177            && VALUE_LVAL (callee) == lval_memory)
11178     callee = value_addr (callee);
11179
11180   struct type *type = ada_check_typedef (value_type (callee));
11181
11182   /* Ada allows us to implicitly dereference arrays when subscripting
11183      them.  So, if this is an array typedef (encoding use for array
11184      access types encoded as fat pointers), strip it now.  */
11185   if (type->code () == TYPE_CODE_TYPEDEF)
11186     type = ada_typedef_target_type (type);
11187
11188   if (type->code () == TYPE_CODE_PTR)
11189     {
11190       switch (ada_check_typedef (type->target_type ())->code ())
11191         {
11192         case TYPE_CODE_FUNC:
11193           type = ada_check_typedef (type->target_type ());
11194           break;
11195         case TYPE_CODE_ARRAY:
11196           break;
11197         case TYPE_CODE_STRUCT:
11198           if (noside != EVAL_AVOID_SIDE_EFFECTS)
11199             callee = ada_value_ind (callee);
11200           type = ada_check_typedef (type->target_type ());
11201           break;
11202         default:
11203           error (_("cannot subscript or call something of type `%s'"),
11204                  ada_type_name (value_type (callee)));
11205           break;
11206         }
11207     }
11208
11209   switch (type->code ())
11210     {
11211     case TYPE_CODE_FUNC:
11212       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11213         {
11214           if (type->target_type () == NULL)
11215             error_call_unknown_return_type (NULL);
11216           return allocate_value (type->target_type ());
11217         }
11218       return call_function_by_hand (callee, NULL, argvec);
11219     case TYPE_CODE_INTERNAL_FUNCTION:
11220       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11221         /* We don't know anything about what the internal
11222            function might return, but we have to return
11223            something.  */
11224         return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11225                            not_lval);
11226       else
11227         return call_internal_function (exp->gdbarch, exp->language_defn,
11228                                        callee, nargs,
11229                                        argvec.data ());
11230
11231     case TYPE_CODE_STRUCT:
11232       {
11233         int arity;
11234
11235         arity = ada_array_arity (type);
11236         type = ada_array_element_type (type, nargs);
11237         if (type == NULL)
11238           error (_("cannot subscript or call a record"));
11239         if (arity != nargs)
11240           error (_("wrong number of subscripts; expecting %d"), arity);
11241         if (noside == EVAL_AVOID_SIDE_EFFECTS)
11242           return value_zero (ada_aligned_type (type), lval_memory);
11243         return
11244           unwrap_value (ada_value_subscript
11245                         (callee, nargs, argvec.data ()));
11246       }
11247     case TYPE_CODE_ARRAY:
11248       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11249         {
11250           type = ada_array_element_type (type, nargs);
11251           if (type == NULL)
11252             error (_("element type of array unknown"));
11253           else
11254             return value_zero (ada_aligned_type (type), lval_memory);
11255         }
11256       return
11257         unwrap_value (ada_value_subscript
11258                       (ada_coerce_to_simple_array (callee),
11259                        nargs, argvec.data ()));
11260     case TYPE_CODE_PTR:     /* Pointer to array */
11261       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11262         {
11263           type = to_fixed_array_type (type->target_type (), NULL, 1);
11264           type = ada_array_element_type (type, nargs);
11265           if (type == NULL)
11266             error (_("element type of array unknown"));
11267           else
11268             return value_zero (ada_aligned_type (type), lval_memory);
11269         }
11270       return
11271         unwrap_value (ada_value_ptr_subscript (callee, nargs,
11272                                                argvec.data ()));
11273
11274     default:
11275       error (_("Attempt to index or call something other than an "
11276                "array or function"));
11277     }
11278 }
11279
11280 bool
11281 ada_funcall_operation::resolve (struct expression *exp,
11282                                 bool deprocedure_p,
11283                                 bool parse_completion,
11284                                 innermost_block_tracker *tracker,
11285                                 struct type *context_type)
11286 {
11287   operation_up &callee_op = std::get<0> (m_storage);
11288
11289   ada_var_value_operation *avv
11290     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11291   if (avv == nullptr)
11292     return false;
11293
11294   symbol *sym = avv->get_symbol ();
11295   if (sym->domain () != UNDEF_DOMAIN)
11296     return false;
11297
11298   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11299   int nargs = args_up.size ();
11300   std::vector<value *> argvec (nargs);
11301
11302   for (int i = 0; i < args_up.size (); ++i)
11303     argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
11304
11305   const block *block = avv->get_block ();
11306   block_symbol resolved
11307     = ada_resolve_funcall (sym, block,
11308                            context_type, parse_completion,
11309                            nargs, argvec.data (),
11310                            tracker);
11311
11312   std::get<0> (m_storage)
11313     = make_operation<ada_var_value_operation> (resolved);
11314   return false;
11315 }
11316
11317 bool
11318 ada_ternop_slice_operation::resolve (struct expression *exp,
11319                                      bool deprocedure_p,
11320                                      bool parse_completion,
11321                                      innermost_block_tracker *tracker,
11322                                      struct type *context_type)
11323 {
11324   /* Historically this check was done during resolution, so we
11325      continue that here.  */
11326   value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
11327                                                 EVAL_AVOID_SIDE_EFFECTS);
11328   if (ada_is_any_packed_array_type (value_type (v)))
11329     error (_("cannot slice a packed array"));
11330   return false;
11331 }
11332
11333 }
11334
11335 \f
11336
11337 /* Return non-zero iff TYPE represents a System.Address type.  */
11338
11339 int
11340 ada_is_system_address_type (struct type *type)
11341 {
11342   return (type->name () && strcmp (type->name (), "system__address") == 0);
11343 }
11344
11345 \f
11346
11347                                 /* Range types */
11348
11349 /* Scan STR beginning at position K for a discriminant name, and
11350    return the value of that discriminant field of DVAL in *PX.  If
11351    PNEW_K is not null, put the position of the character beyond the
11352    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
11353    not alter *PX and *PNEW_K if unsuccessful.  */
11354
11355 static int
11356 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11357                     int *pnew_k)
11358 {
11359   static std::string storage;
11360   const char *pstart, *pend, *bound;
11361   struct value *bound_val;
11362
11363   if (dval == NULL || str == NULL || str[k] == '\0')
11364     return 0;
11365
11366   pstart = str + k;
11367   pend = strstr (pstart, "__");
11368   if (pend == NULL)
11369     {
11370       bound = pstart;
11371       k += strlen (bound);
11372     }
11373   else
11374     {
11375       int len = pend - pstart;
11376
11377       /* Strip __ and beyond.  */
11378       storage = std::string (pstart, len);
11379       bound = storage.c_str ();
11380       k = pend - str;
11381     }
11382
11383   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11384   if (bound_val == NULL)
11385     return 0;
11386
11387   *px = value_as_long (bound_val);
11388   if (pnew_k != NULL)
11389     *pnew_k = k;
11390   return 1;
11391 }
11392
11393 /* Value of variable named NAME.  Only exact matches are considered.
11394    If no such variable found, then if ERR_MSG is null, returns 0, and
11395    otherwise causes an error with message ERR_MSG.  */
11396
11397 static struct value *
11398 get_var_value (const char *name, const char *err_msg)
11399 {
11400   std::string quoted_name = add_angle_brackets (name);
11401
11402   lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
11403
11404   std::vector<struct block_symbol> syms
11405     = ada_lookup_symbol_list_worker (lookup_name,
11406                                      get_selected_block (0),
11407                                      VAR_DOMAIN, 1);
11408
11409   if (syms.size () != 1)
11410     {
11411       if (err_msg == NULL)
11412         return 0;
11413       else
11414         error (("%s"), err_msg);
11415     }
11416
11417   return value_of_variable (syms[0].symbol, syms[0].block);
11418 }
11419
11420 /* Value of integer variable named NAME in the current environment.
11421    If no such variable is found, returns false.  Otherwise, sets VALUE
11422    to the variable's value and returns true.  */
11423
11424 bool
11425 get_int_var_value (const char *name, LONGEST &value)
11426 {
11427   struct value *var_val = get_var_value (name, 0);
11428
11429   if (var_val == 0)
11430     return false;
11431
11432   value = value_as_long (var_val);
11433   return true;
11434 }
11435
11436
11437 /* Return a range type whose base type is that of the range type named
11438    NAME in the current environment, and whose bounds are calculated
11439    from NAME according to the GNAT range encoding conventions.
11440    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
11441    corresponding range type from debug information; fall back to using it
11442    if symbol lookup fails.  If a new type must be created, allocate it
11443    like ORIG_TYPE was.  The bounds information, in general, is encoded
11444    in NAME, the base type given in the named range type.  */
11445
11446 static struct type *
11447 to_fixed_range_type (struct type *raw_type, struct value *dval)
11448 {
11449   const char *name;
11450   struct type *base_type;
11451   const char *subtype_info;
11452
11453   gdb_assert (raw_type != NULL);
11454   gdb_assert (raw_type->name () != NULL);
11455
11456   if (raw_type->code () == TYPE_CODE_RANGE)
11457     base_type = raw_type->target_type ();
11458   else
11459     base_type = raw_type;
11460
11461   name = raw_type->name ();
11462   subtype_info = strstr (name, "___XD");
11463   if (subtype_info == NULL)
11464     {
11465       LONGEST L = ada_discrete_type_low_bound (raw_type);
11466       LONGEST U = ada_discrete_type_high_bound (raw_type);
11467
11468       if (L < INT_MIN || U > INT_MAX)
11469         return raw_type;
11470       else
11471         return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11472                                          L, U);
11473     }
11474   else
11475     {
11476       int prefix_len = subtype_info - name;
11477       LONGEST L, U;
11478       struct type *type;
11479       const char *bounds_str;
11480       int n;
11481
11482       subtype_info += 5;
11483       bounds_str = strchr (subtype_info, '_');
11484       n = 1;
11485
11486       if (*subtype_info == 'L')
11487         {
11488           if (!ada_scan_number (bounds_str, n, &L, &n)
11489               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11490             return raw_type;
11491           if (bounds_str[n] == '_')
11492             n += 2;
11493           else if (bounds_str[n] == '.')     /* FIXME? SGI Workshop kludge.  */
11494             n += 1;
11495           subtype_info += 1;
11496         }
11497       else
11498         {
11499           std::string name_buf = std::string (name, prefix_len) + "___L";
11500           if (!get_int_var_value (name_buf.c_str (), L))
11501             {
11502               lim_warning (_("Unknown lower bound, using 1."));
11503               L = 1;
11504             }
11505         }
11506
11507       if (*subtype_info == 'U')
11508         {
11509           if (!ada_scan_number (bounds_str, n, &U, &n)
11510               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11511             return raw_type;
11512         }
11513       else
11514         {
11515           std::string name_buf = std::string (name, prefix_len) + "___U";
11516           if (!get_int_var_value (name_buf.c_str (), U))
11517             {
11518               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11519               U = L;
11520             }
11521         }
11522
11523       type = create_static_range_type (alloc_type_copy (raw_type),
11524                                        base_type, L, U);
11525       /* create_static_range_type alters the resulting type's length
11526          to match the size of the base_type, which is not what we want.
11527          Set it back to the original range type's length.  */
11528       type->set_length (raw_type->length ());
11529       type->set_name (name);
11530       return type;
11531     }
11532 }
11533
11534 /* True iff NAME is the name of a range type.  */
11535
11536 int
11537 ada_is_range_type_name (const char *name)
11538 {
11539   return (name != NULL && strstr (name, "___XD"));
11540 }
11541 \f
11542
11543                                 /* Modular types */
11544
11545 /* True iff TYPE is an Ada modular type.  */
11546
11547 int
11548 ada_is_modular_type (struct type *type)
11549 {
11550   struct type *subranged_type = get_base_type (type);
11551
11552   return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
11553           && subranged_type->code () == TYPE_CODE_INT
11554           && subranged_type->is_unsigned ());
11555 }
11556
11557 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
11558
11559 ULONGEST
11560 ada_modulus (struct type *type)
11561 {
11562   const dynamic_prop &high = type->bounds ()->high;
11563
11564   if (high.kind () == PROP_CONST)
11565     return (ULONGEST) high.const_val () + 1;
11566
11567   /* If TYPE is unresolved, the high bound might be a location list.  Return
11568      0, for lack of a better value to return.  */
11569   return 0;
11570 }
11571 \f
11572
11573 /* Ada exception catchpoint support:
11574    ---------------------------------
11575
11576    We support 3 kinds of exception catchpoints:
11577      . catchpoints on Ada exceptions
11578      . catchpoints on unhandled Ada exceptions
11579      . catchpoints on failed assertions
11580
11581    Exceptions raised during failed assertions, or unhandled exceptions
11582    could perfectly be caught with the general catchpoint on Ada exceptions.
11583    However, we can easily differentiate these two special cases, and having
11584    the option to distinguish these two cases from the rest can be useful
11585    to zero-in on certain situations.
11586
11587    Exception catchpoints are a specialized form of breakpoint,
11588    since they rely on inserting breakpoints inside known routines
11589    of the GNAT runtime.  The implementation therefore uses a standard
11590    breakpoint structure of the BP_BREAKPOINT type, but with its own set
11591    of breakpoint_ops.
11592
11593    Support in the runtime for exception catchpoints have been changed
11594    a few times already, and these changes affect the implementation
11595    of these catchpoints.  In order to be able to support several
11596    variants of the runtime, we use a sniffer that will determine
11597    the runtime variant used by the program being debugged.  */
11598
11599 /* Ada's standard exceptions.
11600
11601    The Ada 83 standard also defined Numeric_Error.  But there so many
11602    situations where it was unclear from the Ada 83 Reference Manual
11603    (RM) whether Constraint_Error or Numeric_Error should be raised,
11604    that the ARG (Ada Rapporteur Group) eventually issued a Binding
11605    Interpretation saying that anytime the RM says that Numeric_Error
11606    should be raised, the implementation may raise Constraint_Error.
11607    Ada 95 went one step further and pretty much removed Numeric_Error
11608    from the list of standard exceptions (it made it a renaming of
11609    Constraint_Error, to help preserve compatibility when compiling
11610    an Ada83 compiler). As such, we do not include Numeric_Error from
11611    this list of standard exceptions.  */
11612
11613 static const char * const standard_exc[] = {
11614   "constraint_error",
11615   "program_error",
11616   "storage_error",
11617   "tasking_error"
11618 };
11619
11620 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11621
11622 /* A structure that describes how to support exception catchpoints
11623    for a given executable.  */
11624
11625 struct exception_support_info
11626 {
11627    /* The name of the symbol to break on in order to insert
11628       a catchpoint on exceptions.  */
11629    const char *catch_exception_sym;
11630
11631    /* The name of the symbol to break on in order to insert
11632       a catchpoint on unhandled exceptions.  */
11633    const char *catch_exception_unhandled_sym;
11634
11635    /* The name of the symbol to break on in order to insert
11636       a catchpoint on failed assertions.  */
11637    const char *catch_assert_sym;
11638
11639    /* The name of the symbol to break on in order to insert
11640       a catchpoint on exception handling.  */
11641    const char *catch_handlers_sym;
11642
11643    /* Assuming that the inferior just triggered an unhandled exception
11644       catchpoint, this function is responsible for returning the address
11645       in inferior memory where the name of that exception is stored.
11646       Return zero if the address could not be computed.  */
11647    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11648 };
11649
11650 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11651 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11652
11653 /* The following exception support info structure describes how to
11654    implement exception catchpoints with the latest version of the
11655    Ada runtime (as of 2019-08-??).  */
11656
11657 static const struct exception_support_info default_exception_support_info =
11658 {
11659   "__gnat_debug_raise_exception", /* catch_exception_sym */
11660   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11661   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11662   "__gnat_begin_handler_v1", /* catch_handlers_sym */
11663   ada_unhandled_exception_name_addr
11664 };
11665
11666 /* The following exception support info structure describes how to
11667    implement exception catchpoints with an earlier version of the
11668    Ada runtime (as of 2007-03-06) using v0 of the EH ABI.  */
11669
11670 static const struct exception_support_info exception_support_info_v0 =
11671 {
11672   "__gnat_debug_raise_exception", /* catch_exception_sym */
11673   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11674   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11675   "__gnat_begin_handler", /* catch_handlers_sym */
11676   ada_unhandled_exception_name_addr
11677 };
11678
11679 /* The following exception support info structure describes how to
11680    implement exception catchpoints with a slightly older version
11681    of the Ada runtime.  */
11682
11683 static const struct exception_support_info exception_support_info_fallback =
11684 {
11685   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11686   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11687   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
11688   "__gnat_begin_handler", /* catch_handlers_sym */
11689   ada_unhandled_exception_name_addr_from_raise
11690 };
11691
11692 /* Return nonzero if we can detect the exception support routines
11693    described in EINFO.
11694
11695    This function errors out if an abnormal situation is detected
11696    (for instance, if we find the exception support routines, but
11697    that support is found to be incomplete).  */
11698
11699 static int
11700 ada_has_this_exception_support (const struct exception_support_info *einfo)
11701 {
11702   struct symbol *sym;
11703
11704   /* The symbol we're looking up is provided by a unit in the GNAT runtime
11705      that should be compiled with debugging information.  As a result, we
11706      expect to find that symbol in the symtabs.  */
11707
11708   sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11709   if (sym == NULL)
11710     {
11711       /* Perhaps we did not find our symbol because the Ada runtime was
11712          compiled without debugging info, or simply stripped of it.
11713          It happens on some GNU/Linux distributions for instance, where
11714          users have to install a separate debug package in order to get
11715          the runtime's debugging info.  In that situation, let the user
11716          know why we cannot insert an Ada exception catchpoint.
11717
11718          Note: Just for the purpose of inserting our Ada exception
11719          catchpoint, we could rely purely on the associated minimal symbol.
11720          But we would be operating in degraded mode anyway, since we are
11721          still lacking the debugging info needed later on to extract
11722          the name of the exception being raised (this name is printed in
11723          the catchpoint message, and is also used when trying to catch
11724          a specific exception).  We do not handle this case for now.  */
11725       struct bound_minimal_symbol msym
11726         = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11727
11728       if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11729         error (_("Your Ada runtime appears to be missing some debugging "
11730                  "information.\nCannot insert Ada exception catchpoint "
11731                  "in this configuration."));
11732
11733       return 0;
11734     }
11735
11736   /* Make sure that the symbol we found corresponds to a function.  */
11737
11738   if (sym->aclass () != LOC_BLOCK)
11739     {
11740       error (_("Symbol \"%s\" is not a function (class = %d)"),
11741              sym->linkage_name (), sym->aclass ());
11742       return 0;
11743     }
11744
11745   sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11746   if (sym == NULL)
11747     {
11748       struct bound_minimal_symbol msym
11749         = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11750
11751       if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11752         error (_("Your Ada runtime appears to be missing some debugging "
11753                  "information.\nCannot insert Ada exception catchpoint "
11754                  "in this configuration."));
11755
11756       return 0;
11757     }
11758
11759   /* Make sure that the symbol we found corresponds to a function.  */
11760
11761   if (sym->aclass () != LOC_BLOCK)
11762     {
11763       error (_("Symbol \"%s\" is not a function (class = %d)"),
11764              sym->linkage_name (), sym->aclass ());
11765       return 0;
11766     }
11767
11768   return 1;
11769 }
11770
11771 /* Inspect the Ada runtime and determine which exception info structure
11772    should be used to provide support for exception catchpoints.
11773
11774    This function will always set the per-inferior exception_info,
11775    or raise an error.  */
11776
11777 static void
11778 ada_exception_support_info_sniffer (void)
11779 {
11780   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11781
11782   /* If the exception info is already known, then no need to recompute it.  */
11783   if (data->exception_info != NULL)
11784     return;
11785
11786   /* Check the latest (default) exception support info.  */
11787   if (ada_has_this_exception_support (&default_exception_support_info))
11788     {
11789       data->exception_info = &default_exception_support_info;
11790       return;
11791     }
11792
11793   /* Try the v0 exception suport info.  */
11794   if (ada_has_this_exception_support (&exception_support_info_v0))
11795     {
11796       data->exception_info = &exception_support_info_v0;
11797       return;
11798     }
11799
11800   /* Try our fallback exception suport info.  */
11801   if (ada_has_this_exception_support (&exception_support_info_fallback))
11802     {
11803       data->exception_info = &exception_support_info_fallback;
11804       return;
11805     }
11806
11807   /* Sometimes, it is normal for us to not be able to find the routine
11808      we are looking for.  This happens when the program is linked with
11809      the shared version of the GNAT runtime, and the program has not been
11810      started yet.  Inform the user of these two possible causes if
11811      applicable.  */
11812
11813   if (ada_update_initial_language (language_unknown) != language_ada)
11814     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
11815
11816   /* If the symbol does not exist, then check that the program is
11817      already started, to make sure that shared libraries have been
11818      loaded.  If it is not started, this may mean that the symbol is
11819      in a shared library.  */
11820
11821   if (inferior_ptid.pid () == 0)
11822     error (_("Unable to insert catchpoint. Try to start the program first."));
11823
11824   /* At this point, we know that we are debugging an Ada program and
11825      that the inferior has been started, but we still are not able to
11826      find the run-time symbols.  That can mean that we are in
11827      configurable run time mode, or that a-except as been optimized
11828      out by the linker...  In any case, at this point it is not worth
11829      supporting this feature.  */
11830
11831   error (_("Cannot insert Ada exception catchpoints in this configuration."));
11832 }
11833
11834 /* True iff FRAME is very likely to be that of a function that is
11835    part of the runtime system.  This is all very heuristic, but is
11836    intended to be used as advice as to what frames are uninteresting
11837    to most users.  */
11838
11839 static int
11840 is_known_support_routine (struct frame_info *frame)
11841 {
11842   enum language func_lang;
11843   int i;
11844   const char *fullname;
11845
11846   /* If this code does not have any debugging information (no symtab),
11847      This cannot be any user code.  */
11848
11849   symtab_and_line sal = find_frame_sal (frame);
11850   if (sal.symtab == NULL)
11851     return 1;
11852
11853   /* If there is a symtab, but the associated source file cannot be
11854      located, then assume this is not user code:  Selecting a frame
11855      for which we cannot display the code would not be very helpful
11856      for the user.  This should also take care of case such as VxWorks
11857      where the kernel has some debugging info provided for a few units.  */
11858
11859   fullname = symtab_to_fullname (sal.symtab);
11860   if (access (fullname, R_OK) != 0)
11861     return 1;
11862
11863   /* Check the unit filename against the Ada runtime file naming.
11864      We also check the name of the objfile against the name of some
11865      known system libraries that sometimes come with debugging info
11866      too.  */
11867
11868   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11869     {
11870       re_comp (known_runtime_file_name_patterns[i]);
11871       if (re_exec (lbasename (sal.symtab->filename)))
11872         return 1;
11873       if (sal.symtab->compunit ()->objfile () != NULL
11874           && re_exec (objfile_name (sal.symtab->compunit ()->objfile ())))
11875         return 1;
11876     }
11877
11878   /* Check whether the function is a GNAT-generated entity.  */
11879
11880   gdb::unique_xmalloc_ptr<char> func_name
11881     = find_frame_funname (frame, &func_lang, NULL);
11882   if (func_name == NULL)
11883     return 1;
11884
11885   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11886     {
11887       re_comp (known_auxiliary_function_name_patterns[i]);
11888       if (re_exec (func_name.get ()))
11889         return 1;
11890     }
11891
11892   return 0;
11893 }
11894
11895 /* Find the first frame that contains debugging information and that is not
11896    part of the Ada run-time, starting from FI and moving upward.  */
11897
11898 void
11899 ada_find_printable_frame (struct frame_info *fi)
11900 {
11901   for (; fi != NULL; fi = get_prev_frame (fi))
11902     {
11903       if (!is_known_support_routine (fi))
11904         {
11905           select_frame (fi);
11906           break;
11907         }
11908     }
11909
11910 }
11911
11912 /* Assuming that the inferior just triggered an unhandled exception
11913    catchpoint, return the address in inferior memory where the name
11914    of the exception is stored.
11915    
11916    Return zero if the address could not be computed.  */
11917
11918 static CORE_ADDR
11919 ada_unhandled_exception_name_addr (void)
11920 {
11921   return parse_and_eval_address ("e.full_name");
11922 }
11923
11924 /* Same as ada_unhandled_exception_name_addr, except that this function
11925    should be used when the inferior uses an older version of the runtime,
11926    where the exception name needs to be extracted from a specific frame
11927    several frames up in the callstack.  */
11928
11929 static CORE_ADDR
11930 ada_unhandled_exception_name_addr_from_raise (void)
11931 {
11932   int frame_level;
11933   struct frame_info *fi;
11934   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11935
11936   /* To determine the name of this exception, we need to select
11937      the frame corresponding to RAISE_SYM_NAME.  This frame is
11938      at least 3 levels up, so we simply skip the first 3 frames
11939      without checking the name of their associated function.  */
11940   fi = get_current_frame ();
11941   for (frame_level = 0; frame_level < 3; frame_level += 1)
11942     if (fi != NULL)
11943       fi = get_prev_frame (fi); 
11944
11945   while (fi != NULL)
11946     {
11947       enum language func_lang;
11948
11949       gdb::unique_xmalloc_ptr<char> func_name
11950         = find_frame_funname (fi, &func_lang, NULL);
11951       if (func_name != NULL)
11952         {
11953           if (strcmp (func_name.get (),
11954                       data->exception_info->catch_exception_sym) == 0)
11955             break; /* We found the frame we were looking for...  */
11956         }
11957       fi = get_prev_frame (fi);
11958     }
11959
11960   if (fi == NULL)
11961     return 0;
11962
11963   select_frame (fi);
11964   return parse_and_eval_address ("id.full_name");
11965 }
11966
11967 /* Assuming the inferior just triggered an Ada exception catchpoint
11968    (of any type), return the address in inferior memory where the name
11969    of the exception is stored, if applicable.
11970
11971    Assumes the selected frame is the current frame.
11972
11973    Return zero if the address could not be computed, or if not relevant.  */
11974
11975 static CORE_ADDR
11976 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex)
11977 {
11978   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11979
11980   switch (ex)
11981     {
11982       case ada_catch_exception:
11983         return (parse_and_eval_address ("e.full_name"));
11984         break;
11985
11986       case ada_catch_exception_unhandled:
11987         return data->exception_info->unhandled_exception_name_addr ();
11988         break;
11989
11990       case ada_catch_handlers:
11991         return 0;  /* The runtimes does not provide access to the exception
11992                       name.  */
11993         break;
11994
11995       case ada_catch_assert:
11996         return 0;  /* Exception name is not relevant in this case.  */
11997         break;
11998
11999       default:
12000         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12001         break;
12002     }
12003
12004   return 0; /* Should never be reached.  */
12005 }
12006
12007 /* Assuming the inferior is stopped at an exception catchpoint,
12008    return the message which was associated to the exception, if
12009    available.  Return NULL if the message could not be retrieved.
12010
12011    Note: The exception message can be associated to an exception
12012    either through the use of the Raise_Exception function, or
12013    more simply (Ada 2005 and later), via:
12014
12015        raise Exception_Name with "exception message";
12016
12017    */
12018
12019 static gdb::unique_xmalloc_ptr<char>
12020 ada_exception_message_1 (void)
12021 {
12022   struct value *e_msg_val;
12023   int e_msg_len;
12024
12025   /* For runtimes that support this feature, the exception message
12026      is passed as an unbounded string argument called "message".  */
12027   e_msg_val = parse_and_eval ("message");
12028   if (e_msg_val == NULL)
12029     return NULL; /* Exception message not supported.  */
12030
12031   e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12032   gdb_assert (e_msg_val != NULL);
12033   e_msg_len = value_type (e_msg_val)->length ();
12034
12035   /* If the message string is empty, then treat it as if there was
12036      no exception message.  */
12037   if (e_msg_len <= 0)
12038     return NULL;
12039
12040   gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12041   read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
12042                e_msg_len);
12043   e_msg.get ()[e_msg_len] = '\0';
12044
12045   return e_msg;
12046 }
12047
12048 /* Same as ada_exception_message_1, except that all exceptions are
12049    contained here (returning NULL instead).  */
12050
12051 static gdb::unique_xmalloc_ptr<char>
12052 ada_exception_message (void)
12053 {
12054   gdb::unique_xmalloc_ptr<char> e_msg;
12055
12056   try
12057     {
12058       e_msg = ada_exception_message_1 ();
12059     }
12060   catch (const gdb_exception_error &e)
12061     {
12062       e_msg.reset (nullptr);
12063     }
12064
12065   return e_msg;
12066 }
12067
12068 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12069    any error that ada_exception_name_addr_1 might cause to be thrown.
12070    When an error is intercepted, a warning with the error message is printed,
12071    and zero is returned.  */
12072
12073 static CORE_ADDR
12074 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex)
12075 {
12076   CORE_ADDR result = 0;
12077
12078   try
12079     {
12080       result = ada_exception_name_addr_1 (ex);
12081     }
12082
12083   catch (const gdb_exception_error &e)
12084     {
12085       warning (_("failed to get exception name: %s"), e.what ());
12086       return 0;
12087     }
12088
12089   return result;
12090 }
12091
12092 static std::string ada_exception_catchpoint_cond_string
12093   (const char *excep_string,
12094    enum ada_exception_catchpoint_kind ex);
12095
12096 /* Ada catchpoints.
12097
12098    In the case of catchpoints on Ada exceptions, the catchpoint will
12099    stop the target on every exception the program throws.  When a user
12100    specifies the name of a specific exception, we translate this
12101    request into a condition expression (in text form), and then parse
12102    it into an expression stored in each of the catchpoint's locations.
12103    We then use this condition to check whether the exception that was
12104    raised is the one the user is interested in.  If not, then the
12105    target is resumed again.  We store the name of the requested
12106    exception, in order to be able to re-set the condition expression
12107    when symbols change.  */
12108
12109 /* An instance of this type is used to represent an Ada catchpoint.  */
12110
12111 struct ada_catchpoint : public code_breakpoint
12112 {
12113   ada_catchpoint (struct gdbarch *gdbarch_,
12114                   enum ada_exception_catchpoint_kind kind,
12115                   struct symtab_and_line sal,
12116                   const char *addr_string_,
12117                   bool tempflag,
12118                   bool enabled,
12119                   bool from_tty)
12120     : code_breakpoint (gdbarch_, bp_catchpoint),
12121       m_kind (kind)
12122   {
12123     add_location (sal);
12124
12125     /* Unlike most code_breakpoint types, Ada catchpoints are
12126        pspace-specific.  */
12127     gdb_assert (sal.pspace != nullptr);
12128     this->pspace = sal.pspace;
12129
12130     if (from_tty)
12131       {
12132         struct gdbarch *loc_gdbarch = get_sal_arch (sal);
12133         if (!loc_gdbarch)
12134           loc_gdbarch = gdbarch;
12135
12136         describe_other_breakpoints (loc_gdbarch,
12137                                     sal.pspace, sal.pc, sal.section, -1);
12138         /* FIXME: brobecker/2006-12-28: Actually, re-implement a special
12139            version for exception catchpoints, because two catchpoints
12140            used for different exception names will use the same address.
12141            In this case, a "breakpoint ... also set at..." warning is
12142            unproductive.  Besides, the warning phrasing is also a bit
12143            inappropriate, we should use the word catchpoint, and tell
12144            the user what type of catchpoint it is.  The above is good
12145            enough for now, though.  */
12146       }
12147
12148     enable_state = enabled ? bp_enabled : bp_disabled;
12149     disposition = tempflag ? disp_del : disp_donttouch;
12150     locspec = string_to_location_spec (&addr_string_,
12151                                        language_def (language_ada));
12152     language = language_ada;
12153   }
12154
12155   struct bp_location *allocate_location () override;
12156   void re_set () override;
12157   void check_status (struct bpstat *bs) override;
12158   enum print_stop_action print_it (const bpstat *bs) const override;
12159   bool print_one (bp_location **) const override;
12160   void print_mention () const override;
12161   void print_recreate (struct ui_file *fp) const override;
12162
12163   /* The name of the specific exception the user specified.  */
12164   std::string excep_string;
12165
12166   /* What kind of catchpoint this is.  */
12167   enum ada_exception_catchpoint_kind m_kind;
12168 };
12169
12170 /* An instance of this type is used to represent an Ada catchpoint
12171    breakpoint location.  */
12172
12173 class ada_catchpoint_location : public bp_location
12174 {
12175 public:
12176   explicit ada_catchpoint_location (ada_catchpoint *owner)
12177     : bp_location (owner, bp_loc_software_breakpoint)
12178   {}
12179
12180   /* The condition that checks whether the exception that was raised
12181      is the specific exception the user specified on catchpoint
12182      creation.  */
12183   expression_up excep_cond_expr;
12184 };
12185
12186 /* Parse the exception condition string in the context of each of the
12187    catchpoint's locations, and store them for later evaluation.  */
12188
12189 static void
12190 create_excep_cond_exprs (struct ada_catchpoint *c,
12191                          enum ada_exception_catchpoint_kind ex)
12192 {
12193   /* Nothing to do if there's no specific exception to catch.  */
12194   if (c->excep_string.empty ())
12195     return;
12196
12197   /* Same if there are no locations... */
12198   if (c->loc == NULL)
12199     return;
12200
12201   /* Compute the condition expression in text form, from the specific
12202      expection we want to catch.  */
12203   std::string cond_string
12204     = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
12205
12206   /* Iterate over all the catchpoint's locations, and parse an
12207      expression for each.  */
12208   for (bp_location *bl : c->locations ())
12209     {
12210       struct ada_catchpoint_location *ada_loc
12211         = (struct ada_catchpoint_location *) bl;
12212       expression_up exp;
12213
12214       if (!bl->shlib_disabled)
12215         {
12216           const char *s;
12217
12218           s = cond_string.c_str ();
12219           try
12220             {
12221               exp = parse_exp_1 (&s, bl->address,
12222                                  block_for_pc (bl->address),
12223                                  0);
12224             }
12225           catch (const gdb_exception_error &e)
12226             {
12227               warning (_("failed to reevaluate internal exception condition "
12228                          "for catchpoint %d: %s"),
12229                        c->number, e.what ());
12230             }
12231         }
12232
12233       ada_loc->excep_cond_expr = std::move (exp);
12234     }
12235 }
12236
12237 /* Implement the ALLOCATE_LOCATION method in the structure for all
12238    exception catchpoint kinds.  */
12239
12240 struct bp_location *
12241 ada_catchpoint::allocate_location ()
12242 {
12243   return new ada_catchpoint_location (this);
12244 }
12245
12246 /* Implement the RE_SET method in the structure for all exception
12247    catchpoint kinds.  */
12248
12249 void
12250 ada_catchpoint::re_set ()
12251 {
12252   /* Call the base class's method.  This updates the catchpoint's
12253      locations.  */
12254   this->code_breakpoint::re_set ();
12255
12256   /* Reparse the exception conditional expressions.  One for each
12257      location.  */
12258   create_excep_cond_exprs (this, m_kind);
12259 }
12260
12261 /* Returns true if we should stop for this breakpoint hit.  If the
12262    user specified a specific exception, we only want to cause a stop
12263    if the program thrown that exception.  */
12264
12265 static bool
12266 should_stop_exception (const struct bp_location *bl)
12267 {
12268   struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12269   const struct ada_catchpoint_location *ada_loc
12270     = (const struct ada_catchpoint_location *) bl;
12271   bool stop;
12272
12273   struct internalvar *var = lookup_internalvar ("_ada_exception");
12274   if (c->m_kind == ada_catch_assert)
12275     clear_internalvar (var);
12276   else
12277     {
12278       try
12279         {
12280           const char *expr;
12281
12282           if (c->m_kind == ada_catch_handlers)
12283             expr = ("GNAT_GCC_exception_Access(gcc_exception)"
12284                     ".all.occurrence.id");
12285           else
12286             expr = "e";
12287
12288           struct value *exc = parse_and_eval (expr);
12289           set_internalvar (var, exc);
12290         }
12291       catch (const gdb_exception_error &ex)
12292         {
12293           clear_internalvar (var);
12294         }
12295     }
12296
12297   /* With no specific exception, should always stop.  */
12298   if (c->excep_string.empty ())
12299     return true;
12300
12301   if (ada_loc->excep_cond_expr == NULL)
12302     {
12303       /* We will have a NULL expression if back when we were creating
12304          the expressions, this location's had failed to parse.  */
12305       return true;
12306     }
12307
12308   stop = true;
12309   try
12310     {
12311       struct value *mark;
12312
12313       mark = value_mark ();
12314       stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12315       value_free_to_mark (mark);
12316     }
12317   catch (const gdb_exception &ex)
12318     {
12319       exception_fprintf (gdb_stderr, ex,
12320                          _("Error in testing exception condition:\n"));
12321     }
12322
12323   return stop;
12324 }
12325
12326 /* Implement the CHECK_STATUS method in the structure for all
12327    exception catchpoint kinds.  */
12328
12329 void
12330 ada_catchpoint::check_status (bpstat *bs)
12331 {
12332   bs->stop = should_stop_exception (bs->bp_location_at.get ());
12333 }
12334
12335 /* Implement the PRINT_IT method in the structure for all exception
12336    catchpoint kinds.  */
12337
12338 enum print_stop_action
12339 ada_catchpoint::print_it (const bpstat *bs) const
12340 {
12341   struct ui_out *uiout = current_uiout;
12342
12343   annotate_catchpoint (number);
12344
12345   if (uiout->is_mi_like_p ())
12346     {
12347       uiout->field_string ("reason",
12348                            async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12349       uiout->field_string ("disp", bpdisp_text (disposition));
12350     }
12351
12352   uiout->text (disposition == disp_del
12353                ? "\nTemporary catchpoint " : "\nCatchpoint ");
12354   uiout->field_signed ("bkptno", number);
12355   uiout->text (", ");
12356
12357   /* ada_exception_name_addr relies on the selected frame being the
12358      current frame.  Need to do this here because this function may be
12359      called more than once when printing a stop, and below, we'll
12360      select the first frame past the Ada run-time (see
12361      ada_find_printable_frame).  */
12362   select_frame (get_current_frame ());
12363
12364   switch (m_kind)
12365     {
12366       case ada_catch_exception:
12367       case ada_catch_exception_unhandled:
12368       case ada_catch_handlers:
12369         {
12370           const CORE_ADDR addr = ada_exception_name_addr (m_kind);
12371           char exception_name[256];
12372
12373           if (addr != 0)
12374             {
12375               read_memory (addr, (gdb_byte *) exception_name,
12376                            sizeof (exception_name) - 1);
12377               exception_name [sizeof (exception_name) - 1] = '\0';
12378             }
12379           else
12380             {
12381               /* For some reason, we were unable to read the exception
12382                  name.  This could happen if the Runtime was compiled
12383                  without debugging info, for instance.  In that case,
12384                  just replace the exception name by the generic string
12385                  "exception" - it will read as "an exception" in the
12386                  notification we are about to print.  */
12387               memcpy (exception_name, "exception", sizeof ("exception"));
12388             }
12389           /* In the case of unhandled exception breakpoints, we print
12390              the exception name as "unhandled EXCEPTION_NAME", to make
12391              it clearer to the user which kind of catchpoint just got
12392              hit.  We used ui_out_text to make sure that this extra
12393              info does not pollute the exception name in the MI case.  */
12394           if (m_kind == ada_catch_exception_unhandled)
12395             uiout->text ("unhandled ");
12396           uiout->field_string ("exception-name", exception_name);
12397         }
12398         break;
12399       case ada_catch_assert:
12400         /* In this case, the name of the exception is not really
12401            important.  Just print "failed assertion" to make it clearer
12402            that his program just hit an assertion-failure catchpoint.
12403            We used ui_out_text because this info does not belong in
12404            the MI output.  */
12405         uiout->text ("failed assertion");
12406         break;
12407     }
12408
12409   gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
12410   if (exception_message != NULL)
12411     {
12412       uiout->text (" (");
12413       uiout->field_string ("exception-message", exception_message.get ());
12414       uiout->text (")");
12415     }
12416
12417   uiout->text (" at ");
12418   ada_find_printable_frame (get_current_frame ());
12419
12420   return PRINT_SRC_AND_LOC;
12421 }
12422
12423 /* Implement the PRINT_ONE method in the structure for all exception
12424    catchpoint kinds.  */
12425
12426 bool
12427 ada_catchpoint::print_one (bp_location **last_loc) const
12428
12429   struct ui_out *uiout = current_uiout;
12430   struct value_print_options opts;
12431
12432   get_user_print_options (&opts);
12433
12434   if (opts.addressprint)
12435     uiout->field_skip ("addr");
12436
12437   annotate_field (5);
12438   switch (m_kind)
12439     {
12440       case ada_catch_exception:
12441         if (!excep_string.empty ())
12442           {
12443             std::string msg = string_printf (_("`%s' Ada exception"),
12444                                              excep_string.c_str ());
12445
12446             uiout->field_string ("what", msg);
12447           }
12448         else
12449           uiout->field_string ("what", "all Ada exceptions");
12450         
12451         break;
12452
12453       case ada_catch_exception_unhandled:
12454         uiout->field_string ("what", "unhandled Ada exceptions");
12455         break;
12456       
12457       case ada_catch_handlers:
12458         if (!excep_string.empty ())
12459           {
12460             uiout->field_fmt ("what",
12461                               _("`%s' Ada exception handlers"),
12462                               excep_string.c_str ());
12463           }
12464         else
12465           uiout->field_string ("what", "all Ada exceptions handlers");
12466         break;
12467
12468       case ada_catch_assert:
12469         uiout->field_string ("what", "failed Ada assertions");
12470         break;
12471
12472       default:
12473         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12474         break;
12475     }
12476
12477   return true;
12478 }
12479
12480 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12481    for all exception catchpoint kinds.  */
12482
12483 void
12484 ada_catchpoint::print_mention () const
12485 {
12486   struct ui_out *uiout = current_uiout;
12487
12488   uiout->text (disposition == disp_del ? _("Temporary catchpoint ")
12489                                                  : _("Catchpoint "));
12490   uiout->field_signed ("bkptno", number);
12491   uiout->text (": ");
12492
12493   switch (m_kind)
12494     {
12495       case ada_catch_exception:
12496         if (!excep_string.empty ())
12497           {
12498             std::string info = string_printf (_("`%s' Ada exception"),
12499                                               excep_string.c_str ());
12500             uiout->text (info);
12501           }
12502         else
12503           uiout->text (_("all Ada exceptions"));
12504         break;
12505
12506       case ada_catch_exception_unhandled:
12507         uiout->text (_("unhandled Ada exceptions"));
12508         break;
12509
12510       case ada_catch_handlers:
12511         if (!excep_string.empty ())
12512           {
12513             std::string info
12514               = string_printf (_("`%s' Ada exception handlers"),
12515                                excep_string.c_str ());
12516             uiout->text (info);
12517           }
12518         else
12519           uiout->text (_("all Ada exceptions handlers"));
12520         break;
12521
12522       case ada_catch_assert:
12523         uiout->text (_("failed Ada assertions"));
12524         break;
12525
12526       default:
12527         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12528         break;
12529     }
12530 }
12531
12532 /* Implement the PRINT_RECREATE method in the structure for all
12533    exception catchpoint kinds.  */
12534
12535 void
12536 ada_catchpoint::print_recreate (struct ui_file *fp) const
12537 {
12538   switch (m_kind)
12539     {
12540       case ada_catch_exception:
12541         gdb_printf (fp, "catch exception");
12542         if (!excep_string.empty ())
12543           gdb_printf (fp, " %s", excep_string.c_str ());
12544         break;
12545
12546       case ada_catch_exception_unhandled:
12547         gdb_printf (fp, "catch exception unhandled");
12548         break;
12549
12550       case ada_catch_handlers:
12551         gdb_printf (fp, "catch handlers");
12552         break;
12553
12554       case ada_catch_assert:
12555         gdb_printf (fp, "catch assert");
12556         break;
12557
12558       default:
12559         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12560     }
12561   print_recreate_thread (fp);
12562 }
12563
12564 /* See ada-lang.h.  */
12565
12566 bool
12567 is_ada_exception_catchpoint (breakpoint *bp)
12568 {
12569   return dynamic_cast<ada_catchpoint *> (bp) != nullptr;
12570 }
12571
12572 /* Split the arguments specified in a "catch exception" command.  
12573    Set EX to the appropriate catchpoint type.
12574    Set EXCEP_STRING to the name of the specific exception if
12575    specified by the user.
12576    IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12577    "catch handlers" command.  False otherwise.
12578    If a condition is found at the end of the arguments, the condition
12579    expression is stored in COND_STRING (memory must be deallocated
12580    after use).  Otherwise COND_STRING is set to NULL.  */
12581
12582 static void
12583 catch_ada_exception_command_split (const char *args,
12584                                    bool is_catch_handlers_cmd,
12585                                    enum ada_exception_catchpoint_kind *ex,
12586                                    std::string *excep_string,
12587                                    std::string *cond_string)
12588 {
12589   std::string exception_name;
12590
12591   exception_name = extract_arg (&args);
12592   if (exception_name == "if")
12593     {
12594       /* This is not an exception name; this is the start of a condition
12595          expression for a catchpoint on all exceptions.  So, "un-get"
12596          this token, and set exception_name to NULL.  */
12597       exception_name.clear ();
12598       args -= 2;
12599     }
12600
12601   /* Check to see if we have a condition.  */
12602
12603   args = skip_spaces (args);
12604   if (startswith (args, "if")
12605       && (isspace (args[2]) || args[2] == '\0'))
12606     {
12607       args += 2;
12608       args = skip_spaces (args);
12609
12610       if (args[0] == '\0')
12611         error (_("Condition missing after `if' keyword"));
12612       *cond_string = args;
12613
12614       args += strlen (args);
12615     }
12616
12617   /* Check that we do not have any more arguments.  Anything else
12618      is unexpected.  */
12619
12620   if (args[0] != '\0')
12621     error (_("Junk at end of expression"));
12622
12623   if (is_catch_handlers_cmd)
12624     {
12625       /* Catch handling of exceptions.  */
12626       *ex = ada_catch_handlers;
12627       *excep_string = exception_name;
12628     }
12629   else if (exception_name.empty ())
12630     {
12631       /* Catch all exceptions.  */
12632       *ex = ada_catch_exception;
12633       excep_string->clear ();
12634     }
12635   else if (exception_name == "unhandled")
12636     {
12637       /* Catch unhandled exceptions.  */
12638       *ex = ada_catch_exception_unhandled;
12639       excep_string->clear ();
12640     }
12641   else
12642     {
12643       /* Catch a specific exception.  */
12644       *ex = ada_catch_exception;
12645       *excep_string = exception_name;
12646     }
12647 }
12648
12649 /* Return the name of the symbol on which we should break in order to
12650    implement a catchpoint of the EX kind.  */
12651
12652 static const char *
12653 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12654 {
12655   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12656
12657   gdb_assert (data->exception_info != NULL);
12658
12659   switch (ex)
12660     {
12661       case ada_catch_exception:
12662         return (data->exception_info->catch_exception_sym);
12663         break;
12664       case ada_catch_exception_unhandled:
12665         return (data->exception_info->catch_exception_unhandled_sym);
12666         break;
12667       case ada_catch_assert:
12668         return (data->exception_info->catch_assert_sym);
12669         break;
12670       case ada_catch_handlers:
12671         return (data->exception_info->catch_handlers_sym);
12672         break;
12673       default:
12674         internal_error (__FILE__, __LINE__,
12675                         _("unexpected catchpoint kind (%d)"), ex);
12676     }
12677 }
12678
12679 /* Return the condition that will be used to match the current exception
12680    being raised with the exception that the user wants to catch.  This
12681    assumes that this condition is used when the inferior just triggered
12682    an exception catchpoint.
12683    EX: the type of catchpoints used for catching Ada exceptions.  */
12684
12685 static std::string
12686 ada_exception_catchpoint_cond_string (const char *excep_string,
12687                                       enum ada_exception_catchpoint_kind ex)
12688 {
12689   bool is_standard_exc = false;
12690   std::string result;
12691
12692   if (ex == ada_catch_handlers)
12693     {
12694       /* For exception handlers catchpoints, the condition string does
12695          not use the same parameter as for the other exceptions.  */
12696       result = ("long_integer (GNAT_GCC_exception_Access"
12697                 "(gcc_exception).all.occurrence.id)");
12698     }
12699   else
12700     result = "long_integer (e)";
12701
12702   /* The standard exceptions are a special case.  They are defined in
12703      runtime units that have been compiled without debugging info; if
12704      EXCEP_STRING is the not-fully-qualified name of a standard
12705      exception (e.g. "constraint_error") then, during the evaluation
12706      of the condition expression, the symbol lookup on this name would
12707      *not* return this standard exception.  The catchpoint condition
12708      may then be set only on user-defined exceptions which have the
12709      same not-fully-qualified name (e.g. my_package.constraint_error).
12710
12711      To avoid this unexcepted behavior, these standard exceptions are
12712      systematically prefixed by "standard".  This means that "catch
12713      exception constraint_error" is rewritten into "catch exception
12714      standard.constraint_error".
12715
12716      If an exception named constraint_error is defined in another package of
12717      the inferior program, then the only way to specify this exception as a
12718      breakpoint condition is to use its fully-qualified named:
12719      e.g. my_package.constraint_error.  */
12720
12721   for (const char *name : standard_exc)
12722     {
12723       if (strcmp (name, excep_string) == 0)
12724         {
12725           is_standard_exc = true;
12726           break;
12727         }
12728     }
12729
12730   result += " = ";
12731
12732   if (is_standard_exc)
12733     string_appendf (result, "long_integer (&standard.%s)", excep_string);
12734   else
12735     string_appendf (result, "long_integer (&%s)", excep_string);
12736
12737   return result;
12738 }
12739
12740 /* Return the symtab_and_line that should be used to insert an exception
12741    catchpoint of the TYPE kind.
12742
12743    ADDR_STRING returns the name of the function where the real
12744    breakpoint that implements the catchpoints is set, depending on the
12745    type of catchpoint we need to create.  */
12746
12747 static struct symtab_and_line
12748 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12749                    std::string *addr_string)
12750 {
12751   const char *sym_name;
12752   struct symbol *sym;
12753
12754   /* First, find out which exception support info to use.  */
12755   ada_exception_support_info_sniffer ();
12756
12757   /* Then lookup the function on which we will break in order to catch
12758      the Ada exceptions requested by the user.  */
12759   sym_name = ada_exception_sym_name (ex);
12760   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12761
12762   if (sym == NULL)
12763     error (_("Catchpoint symbol not found: %s"), sym_name);
12764
12765   if (sym->aclass () != LOC_BLOCK)
12766     error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12767
12768   /* Set ADDR_STRING.  */
12769   *addr_string = sym_name;
12770
12771   return find_function_start_sal (sym, 1);
12772 }
12773
12774 /* Create an Ada exception catchpoint.
12775
12776    EX_KIND is the kind of exception catchpoint to be created.
12777
12778    If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12779    for all exceptions.  Otherwise, EXCEPT_STRING indicates the name
12780    of the exception to which this catchpoint applies.
12781
12782    COND_STRING, if not empty, is the catchpoint condition.
12783
12784    TEMPFLAG, if nonzero, means that the underlying breakpoint
12785    should be temporary.
12786
12787    FROM_TTY is the usual argument passed to all commands implementations.  */
12788
12789 void
12790 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12791                                  enum ada_exception_catchpoint_kind ex_kind,
12792                                  const std::string &excep_string,
12793                                  const std::string &cond_string,
12794                                  int tempflag,
12795                                  int disabled,
12796                                  int from_tty)
12797 {
12798   std::string addr_string;
12799   struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string);
12800
12801   std::unique_ptr<ada_catchpoint> c
12802     (new ada_catchpoint (gdbarch, ex_kind, sal, addr_string.c_str (),
12803                          tempflag, disabled, from_tty));
12804   c->excep_string = excep_string;
12805   create_excep_cond_exprs (c.get (), ex_kind);
12806   if (!cond_string.empty ())
12807     set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12808   install_breakpoint (0, std::move (c), 1);
12809 }
12810
12811 /* Implement the "catch exception" command.  */
12812
12813 static void
12814 catch_ada_exception_command (const char *arg_entry, int from_tty,
12815                              struct cmd_list_element *command)
12816 {
12817   const char *arg = arg_entry;
12818   struct gdbarch *gdbarch = get_current_arch ();
12819   int tempflag;
12820   enum ada_exception_catchpoint_kind ex_kind;
12821   std::string excep_string;
12822   std::string cond_string;
12823
12824   tempflag = command->context () == CATCH_TEMPORARY;
12825
12826   if (!arg)
12827     arg = "";
12828   catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12829                                      &cond_string);
12830   create_ada_exception_catchpoint (gdbarch, ex_kind,
12831                                    excep_string, cond_string,
12832                                    tempflag, 1 /* enabled */,
12833                                    from_tty);
12834 }
12835
12836 /* Implement the "catch handlers" command.  */
12837
12838 static void
12839 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12840                             struct cmd_list_element *command)
12841 {
12842   const char *arg = arg_entry;
12843   struct gdbarch *gdbarch = get_current_arch ();
12844   int tempflag;
12845   enum ada_exception_catchpoint_kind ex_kind;
12846   std::string excep_string;
12847   std::string cond_string;
12848
12849   tempflag = command->context () == CATCH_TEMPORARY;
12850
12851   if (!arg)
12852     arg = "";
12853   catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12854                                      &cond_string);
12855   create_ada_exception_catchpoint (gdbarch, ex_kind,
12856                                    excep_string, cond_string,
12857                                    tempflag, 1 /* enabled */,
12858                                    from_tty);
12859 }
12860
12861 /* Completion function for the Ada "catch" commands.  */
12862
12863 static void
12864 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12865                      const char *text, const char *word)
12866 {
12867   std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12868
12869   for (const ada_exc_info &info : exceptions)
12870     {
12871       if (startswith (info.name, word))
12872         tracker.add_completion (make_unique_xstrdup (info.name));
12873     }
12874 }
12875
12876 /* Split the arguments specified in a "catch assert" command.
12877
12878    ARGS contains the command's arguments (or the empty string if
12879    no arguments were passed).
12880
12881    If ARGS contains a condition, set COND_STRING to that condition
12882    (the memory needs to be deallocated after use).  */
12883
12884 static void
12885 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12886 {
12887   args = skip_spaces (args);
12888
12889   /* Check whether a condition was provided.  */
12890   if (startswith (args, "if")
12891       && (isspace (args[2]) || args[2] == '\0'))
12892     {
12893       args += 2;
12894       args = skip_spaces (args);
12895       if (args[0] == '\0')
12896         error (_("condition missing after `if' keyword"));
12897       cond_string.assign (args);
12898     }
12899
12900   /* Otherwise, there should be no other argument at the end of
12901      the command.  */
12902   else if (args[0] != '\0')
12903     error (_("Junk at end of arguments."));
12904 }
12905
12906 /* Implement the "catch assert" command.  */
12907
12908 static void
12909 catch_assert_command (const char *arg_entry, int from_tty,
12910                       struct cmd_list_element *command)
12911 {
12912   const char *arg = arg_entry;
12913   struct gdbarch *gdbarch = get_current_arch ();
12914   int tempflag;
12915   std::string cond_string;
12916
12917   tempflag = command->context () == CATCH_TEMPORARY;
12918
12919   if (!arg)
12920     arg = "";
12921   catch_ada_assert_command_split (arg, cond_string);
12922   create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12923                                    "", cond_string,
12924                                    tempflag, 1 /* enabled */,
12925                                    from_tty);
12926 }
12927
12928 /* Return non-zero if the symbol SYM is an Ada exception object.  */
12929
12930 static int
12931 ada_is_exception_sym (struct symbol *sym)
12932 {
12933   const char *type_name = sym->type ()->name ();
12934
12935   return (sym->aclass () != LOC_TYPEDEF
12936           && sym->aclass () != LOC_BLOCK
12937           && sym->aclass () != LOC_CONST
12938           && sym->aclass () != LOC_UNRESOLVED
12939           && type_name != NULL && strcmp (type_name, "exception") == 0);
12940 }
12941
12942 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12943    Ada exception object.  This matches all exceptions except the ones
12944    defined by the Ada language.  */
12945
12946 static int
12947 ada_is_non_standard_exception_sym (struct symbol *sym)
12948 {
12949   if (!ada_is_exception_sym (sym))
12950     return 0;
12951
12952   for (const char *name : standard_exc)
12953     if (strcmp (sym->linkage_name (), name) == 0)
12954       return 0;  /* A standard exception.  */
12955
12956   /* Numeric_Error is also a standard exception, so exclude it.
12957      See the STANDARD_EXC description for more details as to why
12958      this exception is not listed in that array.  */
12959   if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12960     return 0;
12961
12962   return 1;
12963 }
12964
12965 /* A helper function for std::sort, comparing two struct ada_exc_info
12966    objects.
12967
12968    The comparison is determined first by exception name, and then
12969    by exception address.  */
12970
12971 bool
12972 ada_exc_info::operator< (const ada_exc_info &other) const
12973 {
12974   int result;
12975
12976   result = strcmp (name, other.name);
12977   if (result < 0)
12978     return true;
12979   if (result == 0 && addr < other.addr)
12980     return true;
12981   return false;
12982 }
12983
12984 bool
12985 ada_exc_info::operator== (const ada_exc_info &other) const
12986 {
12987   return addr == other.addr && strcmp (name, other.name) == 0;
12988 }
12989
12990 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12991    routine, but keeping the first SKIP elements untouched.
12992
12993    All duplicates are also removed.  */
12994
12995 static void
12996 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
12997                                       int skip)
12998 {
12999   std::sort (exceptions->begin () + skip, exceptions->end ());
13000   exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13001                      exceptions->end ());
13002 }
13003
13004 /* Add all exceptions defined by the Ada standard whose name match
13005    a regular expression.
13006
13007    If PREG is not NULL, then this regexp_t object is used to
13008    perform the symbol name matching.  Otherwise, no name-based
13009    filtering is performed.
13010
13011    EXCEPTIONS is a vector of exceptions to which matching exceptions
13012    gets pushed.  */
13013
13014 static void
13015 ada_add_standard_exceptions (compiled_regex *preg,
13016                              std::vector<ada_exc_info> *exceptions)
13017 {
13018   for (const char *name : standard_exc)
13019     {
13020       if (preg == NULL || preg->exec (name, 0, NULL, 0) == 0)
13021         {
13022           struct bound_minimal_symbol msymbol
13023             = ada_lookup_simple_minsym (name);
13024
13025           if (msymbol.minsym != NULL)
13026             {
13027               struct ada_exc_info info
13028                 = {name, msymbol.value_address ()};
13029
13030               exceptions->push_back (info);
13031             }
13032         }
13033     }
13034 }
13035
13036 /* Add all Ada exceptions defined locally and accessible from the given
13037    FRAME.
13038
13039    If PREG is not NULL, then this regexp_t object is used to
13040    perform the symbol name matching.  Otherwise, no name-based
13041    filtering is performed.
13042
13043    EXCEPTIONS is a vector of exceptions to which matching exceptions
13044    gets pushed.  */
13045
13046 static void
13047 ada_add_exceptions_from_frame (compiled_regex *preg,
13048                                struct frame_info *frame,
13049                                std::vector<ada_exc_info> *exceptions)
13050 {
13051   const struct block *block = get_frame_block (frame, 0);
13052
13053   while (block != 0)
13054     {
13055       struct block_iterator iter;
13056       struct symbol *sym;
13057
13058       ALL_BLOCK_SYMBOLS (block, iter, sym)
13059         {
13060           switch (sym->aclass ())
13061             {
13062             case LOC_TYPEDEF:
13063             case LOC_BLOCK:
13064             case LOC_CONST:
13065               break;
13066             default:
13067               if (ada_is_exception_sym (sym))
13068                 {
13069                   struct ada_exc_info info = {sym->print_name (),
13070                                               sym->value_address ()};
13071
13072                   exceptions->push_back (info);
13073                 }
13074             }
13075         }
13076       if (block->function () != NULL)
13077         break;
13078       block = block->superblock ();
13079     }
13080 }
13081
13082 /* Return true if NAME matches PREG or if PREG is NULL.  */
13083
13084 static bool
13085 name_matches_regex (const char *name, compiled_regex *preg)
13086 {
13087   return (preg == NULL
13088           || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
13089 }
13090
13091 /* Add all exceptions defined globally whose name name match
13092    a regular expression, excluding standard exceptions.
13093
13094    The reason we exclude standard exceptions is that they need
13095    to be handled separately: Standard exceptions are defined inside
13096    a runtime unit which is normally not compiled with debugging info,
13097    and thus usually do not show up in our symbol search.  However,
13098    if the unit was in fact built with debugging info, we need to
13099    exclude them because they would duplicate the entry we found
13100    during the special loop that specifically searches for those
13101    standard exceptions.
13102
13103    If PREG is not NULL, then this regexp_t object is used to
13104    perform the symbol name matching.  Otherwise, no name-based
13105    filtering is performed.
13106
13107    EXCEPTIONS is a vector of exceptions to which matching exceptions
13108    gets pushed.  */
13109
13110 static void
13111 ada_add_global_exceptions (compiled_regex *preg,
13112                            std::vector<ada_exc_info> *exceptions)
13113 {
13114   /* In Ada, the symbol "search name" is a linkage name, whereas the
13115      regular expression used to do the matching refers to the natural
13116      name.  So match against the decoded name.  */
13117   expand_symtabs_matching (NULL,
13118                            lookup_name_info::match_any (),
13119                            [&] (const char *search_name)
13120                            {
13121                              std::string decoded = ada_decode (search_name);
13122                              return name_matches_regex (decoded.c_str (), preg);
13123                            },
13124                            NULL,
13125                            SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13126                            VARIABLES_DOMAIN);
13127
13128   for (objfile *objfile : current_program_space->objfiles ())
13129     {
13130       for (compunit_symtab *s : objfile->compunits ())
13131         {
13132           const struct blockvector *bv = s->blockvector ();
13133           int i;
13134
13135           for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13136             {
13137               const struct block *b = bv->block (i);
13138               struct block_iterator iter;
13139               struct symbol *sym;
13140
13141               ALL_BLOCK_SYMBOLS (b, iter, sym)
13142                 if (ada_is_non_standard_exception_sym (sym)
13143                     && name_matches_regex (sym->natural_name (), preg))
13144                   {
13145                     struct ada_exc_info info
13146                       = {sym->print_name (), sym->value_address ()};
13147
13148                     exceptions->push_back (info);
13149                   }
13150             }
13151         }
13152     }
13153 }
13154
13155 /* Implements ada_exceptions_list with the regular expression passed
13156    as a regex_t, rather than a string.
13157
13158    If not NULL, PREG is used to filter out exceptions whose names
13159    do not match.  Otherwise, all exceptions are listed.  */
13160
13161 static std::vector<ada_exc_info>
13162 ada_exceptions_list_1 (compiled_regex *preg)
13163 {
13164   std::vector<ada_exc_info> result;
13165   int prev_len;
13166
13167   /* First, list the known standard exceptions.  These exceptions
13168      need to be handled separately, as they are usually defined in
13169      runtime units that have been compiled without debugging info.  */
13170
13171   ada_add_standard_exceptions (preg, &result);
13172
13173   /* Next, find all exceptions whose scope is local and accessible
13174      from the currently selected frame.  */
13175
13176   if (has_stack_frames ())
13177     {
13178       prev_len = result.size ();
13179       ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13180                                      &result);
13181       if (result.size () > prev_len)
13182         sort_remove_dups_ada_exceptions_list (&result, prev_len);
13183     }
13184
13185   /* Add all exceptions whose scope is global.  */
13186
13187   prev_len = result.size ();
13188   ada_add_global_exceptions (preg, &result);
13189   if (result.size () > prev_len)
13190     sort_remove_dups_ada_exceptions_list (&result, prev_len);
13191
13192   return result;
13193 }
13194
13195 /* Return a vector of ada_exc_info.
13196
13197    If REGEXP is NULL, all exceptions are included in the result.
13198    Otherwise, it should contain a valid regular expression,
13199    and only the exceptions whose names match that regular expression
13200    are included in the result.
13201
13202    The exceptions are sorted in the following order:
13203      - Standard exceptions (defined by the Ada language), in
13204        alphabetical order;
13205      - Exceptions only visible from the current frame, in
13206        alphabetical order;
13207      - Exceptions whose scope is global, in alphabetical order.  */
13208
13209 std::vector<ada_exc_info>
13210 ada_exceptions_list (const char *regexp)
13211 {
13212   if (regexp == NULL)
13213     return ada_exceptions_list_1 (NULL);
13214
13215   compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13216   return ada_exceptions_list_1 (&reg);
13217 }
13218
13219 /* Implement the "info exceptions" command.  */
13220
13221 static void
13222 info_exceptions_command (const char *regexp, int from_tty)
13223 {
13224   struct gdbarch *gdbarch = get_current_arch ();
13225
13226   std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13227
13228   if (regexp != NULL)
13229     gdb_printf
13230       (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13231   else
13232     gdb_printf (_("All defined Ada exceptions:\n"));
13233
13234   for (const ada_exc_info &info : exceptions)
13235     gdb_printf ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13236 }
13237
13238 \f
13239                                 /* Language vector */
13240
13241 /* symbol_name_matcher_ftype adapter for wild_match.  */
13242
13243 static bool
13244 do_wild_match (const char *symbol_search_name,
13245                const lookup_name_info &lookup_name,
13246                completion_match_result *comp_match_res)
13247 {
13248   return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
13249 }
13250
13251 /* symbol_name_matcher_ftype adapter for full_match.  */
13252
13253 static bool
13254 do_full_match (const char *symbol_search_name,
13255                const lookup_name_info &lookup_name,
13256                completion_match_result *comp_match_res)
13257 {
13258   const char *lname = lookup_name.ada ().lookup_name ().c_str ();
13259
13260   /* If both symbols start with "_ada_", just let the loop below
13261      handle the comparison.  However, if only the symbol name starts
13262      with "_ada_", skip the prefix and let the match proceed as
13263      usual.  */
13264   if (startswith (symbol_search_name, "_ada_")
13265       && !startswith (lname, "_ada"))
13266     symbol_search_name += 5;
13267   /* Likewise for ghost entities.  */
13268   if (startswith (symbol_search_name, "___ghost_")
13269       && !startswith (lname, "___ghost_"))
13270     symbol_search_name += 9;
13271
13272   int uscore_count = 0;
13273   while (*lname != '\0')
13274     {
13275       if (*symbol_search_name != *lname)
13276         {
13277           if (*symbol_search_name == 'B' && uscore_count == 2
13278               && symbol_search_name[1] == '_')
13279             {
13280               symbol_search_name += 2;
13281               while (isdigit (*symbol_search_name))
13282                 ++symbol_search_name;
13283               if (symbol_search_name[0] == '_'
13284                   && symbol_search_name[1] == '_')
13285                 {
13286                   symbol_search_name += 2;
13287                   continue;
13288                 }
13289             }
13290           return false;
13291         }
13292
13293       if (*symbol_search_name == '_')
13294         ++uscore_count;
13295       else
13296         uscore_count = 0;
13297
13298       ++symbol_search_name;
13299       ++lname;
13300     }
13301
13302   return is_name_suffix (symbol_search_name);
13303 }
13304
13305 /* symbol_name_matcher_ftype for exact (verbatim) matches.  */
13306
13307 static bool
13308 do_exact_match (const char *symbol_search_name,
13309                 const lookup_name_info &lookup_name,
13310                 completion_match_result *comp_match_res)
13311 {
13312   return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
13313 }
13314
13315 /* Build the Ada lookup name for LOOKUP_NAME.  */
13316
13317 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
13318 {
13319   gdb::string_view user_name = lookup_name.name ();
13320
13321   if (!user_name.empty () && user_name[0] == '<')
13322     {
13323       if (user_name.back () == '>')
13324         m_encoded_name
13325           = gdb::to_string (user_name.substr (1, user_name.size () - 2));
13326       else
13327         m_encoded_name
13328           = gdb::to_string (user_name.substr (1, user_name.size () - 1));
13329       m_encoded_p = true;
13330       m_verbatim_p = true;
13331       m_wild_match_p = false;
13332       m_standard_p = false;
13333     }
13334   else
13335     {
13336       m_verbatim_p = false;
13337
13338       m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
13339
13340       if (!m_encoded_p)
13341         {
13342           const char *folded = ada_fold_name (user_name);
13343           m_encoded_name = ada_encode_1 (folded, false);
13344           if (m_encoded_name.empty ())
13345             m_encoded_name = gdb::to_string (user_name);
13346         }
13347       else
13348         m_encoded_name = gdb::to_string (user_name);
13349
13350       /* Handle the 'package Standard' special case.  See description
13351          of m_standard_p.  */
13352       if (startswith (m_encoded_name.c_str (), "standard__"))
13353         {
13354           m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
13355           m_standard_p = true;
13356         }
13357       else
13358         m_standard_p = false;
13359
13360       /* If the name contains a ".", then the user is entering a fully
13361          qualified entity name, and the match must not be done in wild
13362          mode.  Similarly, if the user wants to complete what looks
13363          like an encoded name, the match must not be done in wild
13364          mode.  Also, in the standard__ special case always do
13365          non-wild matching.  */
13366       m_wild_match_p
13367         = (lookup_name.match_type () != symbol_name_match_type::FULL
13368            && !m_encoded_p
13369            && !m_standard_p
13370            && user_name.find ('.') == std::string::npos);
13371     }
13372 }
13373
13374 /* symbol_name_matcher_ftype method for Ada.  This only handles
13375    completion mode.  */
13376
13377 static bool
13378 ada_symbol_name_matches (const char *symbol_search_name,
13379                          const lookup_name_info &lookup_name,
13380                          completion_match_result *comp_match_res)
13381 {
13382   return lookup_name.ada ().matches (symbol_search_name,
13383                                      lookup_name.match_type (),
13384                                      comp_match_res);
13385 }
13386
13387 /* A name matcher that matches the symbol name exactly, with
13388    strcmp.  */
13389
13390 static bool
13391 literal_symbol_name_matcher (const char *symbol_search_name,
13392                              const lookup_name_info &lookup_name,
13393                              completion_match_result *comp_match_res)
13394 {
13395   gdb::string_view name_view = lookup_name.name ();
13396
13397   if (lookup_name.completion_mode ()
13398       ? (strncmp (symbol_search_name, name_view.data (),
13399                   name_view.size ()) == 0)
13400       : symbol_search_name == name_view)
13401     {
13402       if (comp_match_res != NULL)
13403         comp_match_res->set_match (symbol_search_name);
13404       return true;
13405     }
13406   else
13407     return false;
13408 }
13409
13410 /* Implement the "get_symbol_name_matcher" language_defn method for
13411    Ada.  */
13412
13413 static symbol_name_matcher_ftype *
13414 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
13415 {
13416   if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
13417     return literal_symbol_name_matcher;
13418
13419   if (lookup_name.completion_mode ())
13420     return ada_symbol_name_matches;
13421   else
13422     {
13423       if (lookup_name.ada ().wild_match_p ())
13424         return do_wild_match;
13425       else if (lookup_name.ada ().verbatim_p ())
13426         return do_exact_match;
13427       else
13428         return do_full_match;
13429     }
13430 }
13431
13432 /* Class representing the Ada language.  */
13433
13434 class ada_language : public language_defn
13435 {
13436 public:
13437   ada_language ()
13438     : language_defn (language_ada)
13439   { /* Nothing.  */ }
13440
13441   /* See language.h.  */
13442
13443   const char *name () const override
13444   { return "ada"; }
13445
13446   /* See language.h.  */
13447
13448   const char *natural_name () const override
13449   { return "Ada"; }
13450
13451   /* See language.h.  */
13452
13453   const std::vector<const char *> &filename_extensions () const override
13454   {
13455     static const std::vector<const char *> extensions
13456       = { ".adb", ".ads", ".a", ".ada", ".dg" };
13457     return extensions;
13458   }
13459
13460   /* Print an array element index using the Ada syntax.  */
13461
13462   void print_array_index (struct type *index_type,
13463                           LONGEST index,
13464                           struct ui_file *stream,
13465                           const value_print_options *options) const override
13466   {
13467     struct value *index_value = val_atr (index_type, index);
13468
13469     value_print (index_value, stream, options);
13470     gdb_printf (stream, " => ");
13471   }
13472
13473   /* Implement the "read_var_value" language_defn method for Ada.  */
13474
13475   struct value *read_var_value (struct symbol *var,
13476                                 const struct block *var_block,
13477                                 struct frame_info *frame) const override
13478   {
13479     /* The only case where default_read_var_value is not sufficient
13480        is when VAR is a renaming...  */
13481     if (frame != nullptr)
13482       {
13483         const struct block *frame_block = get_frame_block (frame, NULL);
13484         if (frame_block != nullptr && ada_is_renaming_symbol (var))
13485           return ada_read_renaming_var_value (var, frame_block);
13486       }
13487
13488     /* This is a typical case where we expect the default_read_var_value
13489        function to work.  */
13490     return language_defn::read_var_value (var, var_block, frame);
13491   }
13492
13493   /* See language.h.  */
13494   bool symbol_printing_suppressed (struct symbol *symbol) const override
13495   {
13496     return symbol->is_artificial ();
13497   }
13498
13499   /* See language.h.  */
13500   void language_arch_info (struct gdbarch *gdbarch,
13501                            struct language_arch_info *lai) const override
13502   {
13503     const struct builtin_type *builtin = builtin_type (gdbarch);
13504
13505     /* Helper function to allow shorter lines below.  */
13506     auto add = [&] (struct type *t)
13507     {
13508       lai->add_primitive_type (t);
13509     };
13510
13511     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13512                             0, "integer"));
13513     add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13514                             0, "long_integer"));
13515     add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13516                             0, "short_integer"));
13517     struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
13518                                                   1, "character");
13519     lai->set_string_char_type (char_type);
13520     add (char_type);
13521     add (arch_character_type (gdbarch, 16, 1, "wide_character"));
13522     add (arch_character_type (gdbarch, 32, 1, "wide_wide_character"));
13523     add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13524                           "float", gdbarch_float_format (gdbarch)));
13525     add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13526                           "long_float", gdbarch_double_format (gdbarch)));
13527     add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13528                             0, "long_long_integer"));
13529     add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13530                           "long_long_float",
13531                           gdbarch_long_double_format (gdbarch)));
13532     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13533                             0, "natural"));
13534     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13535                             0, "positive"));
13536     add (builtin->builtin_void);
13537
13538     struct type *system_addr_ptr
13539       = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13540                                         "void"));
13541     system_addr_ptr->set_name ("system__address");
13542     add (system_addr_ptr);
13543
13544     /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13545        type.  This is a signed integral type whose size is the same as
13546        the size of addresses.  */
13547     unsigned int addr_length = system_addr_ptr->length ();
13548     add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13549                             "storage_offset"));
13550
13551     lai->set_bool_type (builtin->builtin_bool);
13552   }
13553
13554   /* See language.h.  */
13555
13556   bool iterate_over_symbols
13557         (const struct block *block, const lookup_name_info &name,
13558          domain_enum domain,
13559          gdb::function_view<symbol_found_callback_ftype> callback) const override
13560   {
13561     std::vector<struct block_symbol> results
13562       = ada_lookup_symbol_list_worker (name, block, domain, 0);
13563     for (block_symbol &sym : results)
13564       {
13565         if (!callback (&sym))
13566           return false;
13567       }
13568
13569     return true;
13570   }
13571
13572   /* See language.h.  */
13573   bool sniff_from_mangled_name
13574        (const char *mangled,
13575         gdb::unique_xmalloc_ptr<char> *out) const override
13576   {
13577     std::string demangled = ada_decode (mangled);
13578
13579     *out = NULL;
13580
13581     if (demangled != mangled && demangled[0] != '<')
13582       {
13583         /* Set the gsymbol language to Ada, but still return 0.
13584            Two reasons for that:
13585
13586            1. For Ada, we prefer computing the symbol's decoded name
13587            on the fly rather than pre-compute it, in order to save
13588            memory (Ada projects are typically very large).
13589
13590            2. There are some areas in the definition of the GNAT
13591            encoding where, with a bit of bad luck, we might be able
13592            to decode a non-Ada symbol, generating an incorrect
13593            demangled name (Eg: names ending with "TB" for instance
13594            are identified as task bodies and so stripped from
13595            the decoded name returned).
13596
13597            Returning true, here, but not setting *DEMANGLED, helps us get
13598            a little bit of the best of both worlds.  Because we're last,
13599            we should not affect any of the other languages that were
13600            able to demangle the symbol before us; we get to correctly
13601            tag Ada symbols as such; and even if we incorrectly tagged a
13602            non-Ada symbol, which should be rare, any routing through the
13603            Ada language should be transparent (Ada tries to behave much
13604            like C/C++ with non-Ada symbols).  */
13605         return true;
13606       }
13607
13608     return false;
13609   }
13610
13611   /* See language.h.  */
13612
13613   gdb::unique_xmalloc_ptr<char> demangle_symbol (const char *mangled,
13614                                                  int options) const override
13615   {
13616     return make_unique_xstrdup (ada_decode (mangled).c_str ());
13617   }
13618
13619   /* See language.h.  */
13620
13621   void print_type (struct type *type, const char *varstring,
13622                    struct ui_file *stream, int show, int level,
13623                    const struct type_print_options *flags) const override
13624   {
13625     ada_print_type (type, varstring, stream, show, level, flags);
13626   }
13627
13628   /* See language.h.  */
13629
13630   const char *word_break_characters (void) const override
13631   {
13632     return ada_completer_word_break_characters;
13633   }
13634
13635   /* See language.h.  */
13636
13637   void collect_symbol_completion_matches (completion_tracker &tracker,
13638                                           complete_symbol_mode mode,
13639                                           symbol_name_match_type name_match_type,
13640                                           const char *text, const char *word,
13641                                           enum type_code code) const override
13642   {
13643     struct symbol *sym;
13644     const struct block *b, *surrounding_static_block = 0;
13645     struct block_iterator iter;
13646
13647     gdb_assert (code == TYPE_CODE_UNDEF);
13648
13649     lookup_name_info lookup_name (text, name_match_type, true);
13650
13651     /* First, look at the partial symtab symbols.  */
13652     expand_symtabs_matching (NULL,
13653                              lookup_name,
13654                              NULL,
13655                              NULL,
13656                              SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13657                              ALL_DOMAIN);
13658
13659     /* At this point scan through the misc symbol vectors and add each
13660        symbol you find to the list.  Eventually we want to ignore
13661        anything that isn't a text symbol (everything else will be
13662        handled by the psymtab code above).  */
13663
13664     for (objfile *objfile : current_program_space->objfiles ())
13665       {
13666         for (minimal_symbol *msymbol : objfile->msymbols ())
13667           {
13668             QUIT;
13669
13670             if (completion_skip_symbol (mode, msymbol))
13671               continue;
13672
13673             language symbol_language = msymbol->language ();
13674
13675             /* Ada minimal symbols won't have their language set to Ada.  If
13676                we let completion_list_add_name compare using the
13677                default/C-like matcher, then when completing e.g., symbols in a
13678                package named "pck", we'd match internal Ada symbols like
13679                "pckS", which are invalid in an Ada expression, unless you wrap
13680                them in '<' '>' to request a verbatim match.
13681
13682                Unfortunately, some Ada encoded names successfully demangle as
13683                C++ symbols (using an old mangling scheme), such as "name__2Xn"
13684                -> "Xn::name(void)" and thus some Ada minimal symbols end up
13685                with the wrong language set.  Paper over that issue here.  */
13686             if (symbol_language == language_auto
13687                 || symbol_language == language_cplus)
13688               symbol_language = language_ada;
13689
13690             completion_list_add_name (tracker,
13691                                       symbol_language,
13692                                       msymbol->linkage_name (),
13693                                       lookup_name, text, word);
13694           }
13695       }
13696
13697     /* Search upwards from currently selected frame (so that we can
13698        complete on local vars.  */
13699
13700     for (b = get_selected_block (0); b != NULL; b = b->superblock ())
13701       {
13702         if (!b->superblock ())
13703           surrounding_static_block = b;   /* For elmin of dups */
13704
13705         ALL_BLOCK_SYMBOLS (b, iter, sym)
13706           {
13707             if (completion_skip_symbol (mode, sym))
13708               continue;
13709
13710             completion_list_add_name (tracker,
13711                                       sym->language (),
13712                                       sym->linkage_name (),
13713                                       lookup_name, text, word);
13714           }
13715       }
13716
13717     /* Go through the symtabs and check the externs and statics for
13718        symbols which match.  */
13719
13720     for (objfile *objfile : current_program_space->objfiles ())
13721       {
13722         for (compunit_symtab *s : objfile->compunits ())
13723           {
13724             QUIT;
13725             b = s->blockvector ()->global_block ();
13726             ALL_BLOCK_SYMBOLS (b, iter, sym)
13727               {
13728                 if (completion_skip_symbol (mode, sym))
13729                   continue;
13730
13731                 completion_list_add_name (tracker,
13732                                           sym->language (),
13733                                           sym->linkage_name (),
13734                                           lookup_name, text, word);
13735               }
13736           }
13737       }
13738
13739     for (objfile *objfile : current_program_space->objfiles ())
13740       {
13741         for (compunit_symtab *s : objfile->compunits ())
13742           {
13743             QUIT;
13744             b = s->blockvector ()->static_block ();
13745             /* Don't do this block twice.  */
13746             if (b == surrounding_static_block)
13747               continue;
13748             ALL_BLOCK_SYMBOLS (b, iter, sym)
13749               {
13750                 if (completion_skip_symbol (mode, sym))
13751                   continue;
13752
13753                 completion_list_add_name (tracker,
13754                                           sym->language (),
13755                                           sym->linkage_name (),
13756                                           lookup_name, text, word);
13757               }
13758           }
13759       }
13760   }
13761
13762   /* See language.h.  */
13763
13764   gdb::unique_xmalloc_ptr<char> watch_location_expression
13765         (struct type *type, CORE_ADDR addr) const override
13766   {
13767     type = check_typedef (check_typedef (type)->target_type ());
13768     std::string name = type_to_string (type);
13769     return xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr));
13770   }
13771
13772   /* See language.h.  */
13773
13774   void value_print (struct value *val, struct ui_file *stream,
13775                     const struct value_print_options *options) const override
13776   {
13777     return ada_value_print (val, stream, options);
13778   }
13779
13780   /* See language.h.  */
13781
13782   void value_print_inner
13783         (struct value *val, struct ui_file *stream, int recurse,
13784          const struct value_print_options *options) const override
13785   {
13786     return ada_value_print_inner (val, stream, recurse, options);
13787   }
13788
13789   /* See language.h.  */
13790
13791   struct block_symbol lookup_symbol_nonlocal
13792         (const char *name, const struct block *block,
13793          const domain_enum domain) const override
13794   {
13795     struct block_symbol sym;
13796
13797     sym = ada_lookup_symbol (name, block_static_block (block), domain);
13798     if (sym.symbol != NULL)
13799       return sym;
13800
13801     /* If we haven't found a match at this point, try the primitive
13802        types.  In other languages, this search is performed before
13803        searching for global symbols in order to short-circuit that
13804        global-symbol search if it happens that the name corresponds
13805        to a primitive type.  But we cannot do the same in Ada, because
13806        it is perfectly legitimate for a program to declare a type which
13807        has the same name as a standard type.  If looking up a type in
13808        that situation, we have traditionally ignored the primitive type
13809        in favor of user-defined types.  This is why, unlike most other
13810        languages, we search the primitive types this late and only after
13811        having searched the global symbols without success.  */
13812
13813     if (domain == VAR_DOMAIN)
13814       {
13815         struct gdbarch *gdbarch;
13816
13817         if (block == NULL)
13818           gdbarch = target_gdbarch ();
13819         else
13820           gdbarch = block_gdbarch (block);
13821         sym.symbol
13822           = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13823         if (sym.symbol != NULL)
13824           return sym;
13825       }
13826
13827     return {};
13828   }
13829
13830   /* See language.h.  */
13831
13832   int parser (struct parser_state *ps) const override
13833   {
13834     warnings_issued = 0;
13835     return ada_parse (ps);
13836   }
13837
13838   /* See language.h.  */
13839
13840   void emitchar (int ch, struct type *chtype,
13841                  struct ui_file *stream, int quoter) const override
13842   {
13843     ada_emit_char (ch, chtype, stream, quoter, 1);
13844   }
13845
13846   /* See language.h.  */
13847
13848   void printchar (int ch, struct type *chtype,
13849                   struct ui_file *stream) const override
13850   {
13851     ada_printchar (ch, chtype, stream);
13852   }
13853
13854   /* See language.h.  */
13855
13856   void printstr (struct ui_file *stream, struct type *elttype,
13857                  const gdb_byte *string, unsigned int length,
13858                  const char *encoding, int force_ellipses,
13859                  const struct value_print_options *options) const override
13860   {
13861     ada_printstr (stream, elttype, string, length, encoding,
13862                   force_ellipses, options);
13863   }
13864
13865   /* See language.h.  */
13866
13867   void print_typedef (struct type *type, struct symbol *new_symbol,
13868                       struct ui_file *stream) const override
13869   {
13870     ada_print_typedef (type, new_symbol, stream);
13871   }
13872
13873   /* See language.h.  */
13874
13875   bool is_string_type_p (struct type *type) const override
13876   {
13877     return ada_is_string_type (type);
13878   }
13879
13880   /* See language.h.  */
13881
13882   const char *struct_too_deep_ellipsis () const override
13883   { return "(...)"; }
13884
13885   /* See language.h.  */
13886
13887   bool c_style_arrays_p () const override
13888   { return false; }
13889
13890   /* See language.h.  */
13891
13892   bool store_sym_names_in_linkage_form_p () const override
13893   { return true; }
13894
13895   /* See language.h.  */
13896
13897   const struct lang_varobj_ops *varobj_ops () const override
13898   { return &ada_varobj_ops; }
13899
13900 protected:
13901   /* See language.h.  */
13902
13903   symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13904         (const lookup_name_info &lookup_name) const override
13905   {
13906     return ada_get_symbol_name_matcher (lookup_name);
13907   }
13908 };
13909
13910 /* Single instance of the Ada language class.  */
13911
13912 static ada_language ada_language_defn;
13913
13914 /* Command-list for the "set/show ada" prefix command.  */
13915 static struct cmd_list_element *set_ada_list;
13916 static struct cmd_list_element *show_ada_list;
13917
13918 /* This module's 'new_objfile' observer.  */
13919
13920 static void
13921 ada_new_objfile_observer (struct objfile *objfile)
13922 {
13923   ada_clear_symbol_cache ();
13924 }
13925
13926 /* This module's 'free_objfile' observer.  */
13927
13928 static void
13929 ada_free_objfile_observer (struct objfile *objfile)
13930 {
13931   ada_clear_symbol_cache ();
13932 }
13933
13934 /* Charsets known to GNAT.  */
13935 static const char * const gnat_source_charsets[] =
13936 {
13937   /* Note that code below assumes that the default comes first.
13938      Latin-1 is the default here, because that is also GNAT's
13939      default.  */
13940   "ISO-8859-1",
13941   "ISO-8859-2",
13942   "ISO-8859-3",
13943   "ISO-8859-4",
13944   "ISO-8859-5",
13945   "ISO-8859-15",
13946   "CP437",
13947   "CP850",
13948   /* Note that this value is special-cased in the encoder and
13949      decoder.  */
13950   ada_utf8,
13951   nullptr
13952 };
13953
13954 void _initialize_ada_language ();
13955 void
13956 _initialize_ada_language ()
13957 {
13958   add_setshow_prefix_cmd
13959     ("ada", no_class,
13960      _("Prefix command for changing Ada-specific settings."),
13961      _("Generic command for showing Ada-specific settings."),
13962      &set_ada_list, &show_ada_list,
13963      &setlist, &showlist);
13964
13965   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13966                            &trust_pad_over_xvs, _("\
13967 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13968 Show whether an optimization trusting PAD types over XVS types is activated."),
13969                            _("\
13970 This is related to the encoding used by the GNAT compiler.  The debugger\n\
13971 should normally trust the contents of PAD types, but certain older versions\n\
13972 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13973 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
13974 work around this bug.  It is always safe to turn this option \"off\", but\n\
13975 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13976 this option to \"off\" unless necessary."),
13977                             NULL, NULL, &set_ada_list, &show_ada_list);
13978
13979   add_setshow_boolean_cmd ("print-signatures", class_vars,
13980                            &print_signatures, _("\
13981 Enable or disable the output of formal and return types for functions in the \
13982 overloads selection menu."), _("\
13983 Show whether the output of formal and return types for functions in the \
13984 overloads selection menu is activated."),
13985                            NULL, NULL, NULL, &set_ada_list, &show_ada_list);
13986
13987   ada_source_charset = gnat_source_charsets[0];
13988   add_setshow_enum_cmd ("source-charset", class_files,
13989                         gnat_source_charsets,
13990                         &ada_source_charset,  _("\
13991 Set the Ada source character set."), _("\
13992 Show the Ada source character set."), _("\
13993 The character set used for Ada source files.\n\
13994 This must correspond to the '-gnati' or '-gnatW' option passed to GNAT."),
13995                         nullptr, nullptr,
13996                         &set_ada_list, &show_ada_list);
13997
13998   add_catch_command ("exception", _("\
13999 Catch Ada exceptions, when raised.\n\
14000 Usage: catch exception [ARG] [if CONDITION]\n\
14001 Without any argument, stop when any Ada exception is raised.\n\
14002 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14003 being raised does not have a handler (and will therefore lead to the task's\n\
14004 termination).\n\
14005 Otherwise, the catchpoint only stops when the name of the exception being\n\
14006 raised is the same as ARG.\n\
14007 CONDITION is a boolean expression that is evaluated to see whether the\n\
14008 exception should cause a stop."),
14009                      catch_ada_exception_command,
14010                      catch_ada_completer,
14011                      CATCH_PERMANENT,
14012                      CATCH_TEMPORARY);
14013
14014   add_catch_command ("handlers", _("\
14015 Catch Ada exceptions, when handled.\n\
14016 Usage: catch handlers [ARG] [if CONDITION]\n\
14017 Without any argument, stop when any Ada exception is handled.\n\
14018 With an argument, catch only exceptions with the given name.\n\
14019 CONDITION is a boolean expression that is evaluated to see whether the\n\
14020 exception should cause a stop."),
14021                      catch_ada_handlers_command,
14022                      catch_ada_completer,
14023                      CATCH_PERMANENT,
14024                      CATCH_TEMPORARY);
14025   add_catch_command ("assert", _("\
14026 Catch failed Ada assertions, when raised.\n\
14027 Usage: catch assert [if CONDITION]\n\
14028 CONDITION is a boolean expression that is evaluated to see whether the\n\
14029 exception should cause a stop."),
14030                      catch_assert_command,
14031                      NULL,
14032                      CATCH_PERMANENT,
14033                      CATCH_TEMPORARY);
14034
14035   add_info ("exceptions", info_exceptions_command,
14036             _("\
14037 List all Ada exception names.\n\
14038 Usage: info exceptions [REGEXP]\n\
14039 If a regular expression is passed as an argument, only those matching\n\
14040 the regular expression are listed."));
14041
14042   add_setshow_prefix_cmd ("ada", class_maintenance,
14043                           _("Set Ada maintenance-related variables."),
14044                           _("Show Ada maintenance-related variables."),
14045                           &maint_set_ada_cmdlist, &maint_show_ada_cmdlist,
14046                           &maintenance_set_cmdlist, &maintenance_show_cmdlist);
14047
14048   add_setshow_boolean_cmd
14049     ("ignore-descriptive-types", class_maintenance,
14050      &ada_ignore_descriptive_types_p,
14051      _("Set whether descriptive types generated by GNAT should be ignored."),
14052      _("Show whether descriptive types generated by GNAT should be ignored."),
14053      _("\
14054 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14055 DWARF attribute."),
14056      NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14057
14058   decoded_names_store = htab_create_alloc (256, htab_hash_string,
14059                                            htab_eq_string,
14060                                            NULL, xcalloc, xfree);
14061
14062   /* The ada-lang observers.  */
14063   gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
14064   gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
14065   gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");
14066 }
This page took 0.81216 seconds and 4 git commands to generate.