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